[thirdparty/gcc.git] / libgfortran / intrinsics / unpack_generic.c

/* Generic implementation of the UNPACK intrinsic
   Copyright 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

This file is part of the GNU Fortran 95 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 2 of the License, or (at your option) any later version.

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

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.

You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING.  If not,
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */

#include "config.h"
#include <stdlib.h>
#include <assert.h>
#include <string.h>
#include "libgfortran.h"

static void
unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
		 const gfc_array_l4 *mask, const gfc_array_char *field,
		 index_type size, index_type fsize)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type rs;
  char *rptr;
  /* v.* indicates the vector array.  */
  index_type vstride0;
  char *vptr;
  /* f.* indicates the field array.  */
  index_type fstride[GFC_MAX_DIMENSIONS];
  index_type fstride0;
  const char *fptr;
  /* m.* indicates the mask array.  */
  index_type mstride[GFC_MAX_DIMENSIONS];
  index_type mstride0;
  const GFC_LOGICAL_4 *mptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type n;
  index_type dim;

  if (ret->data == 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;
	  ret->dim[n].stride = rs;
	  ret->dim[n].lbound = 0;
	  ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
	  extent[n] = ret->dim[n].ubound + 1;
	  rstride[n] = ret->dim[n].stride * size;
	  fstride[n] = field->dim[n].stride * fsize;
	  mstride[n] = mask->dim[n].stride;
	  rs *= extent[n];
	}
      ret->offset = 0;
      ret->data = internal_malloc_size (rs * size);
    }
  else
    {
      dim = GFC_DESCRIPTOR_RANK (ret);
      for (n = 0; n < dim; n++)
	{
	  count[n] = 0;
	  extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
	  rstride[n] = ret->dim[n].stride * size;
	  fstride[n] = field->dim[n].stride * fsize;
	  mstride[n] = mask->dim[n].stride;
	}
      if (rstride[0] == 0)
	rstride[0] = size;
    }
  if (fstride[0] == 0)
    fstride[0] = fsize;
  if (mstride[0] == 0)
    mstride[0] = 1;

  vstride0 = vector->dim[0].stride * size;
  if (vstride0 == 0)
    vstride0 = size;
  rstride0 = rstride[0];
  fstride0 = fstride[0];
  mstride0 = mstride[0];
  rptr = ret->data;
  fptr = field->data;
  mptr = mask->data;
  vptr = vector->data;

  /* Use the same loop for both logical types. */
  if (GFC_DESCRIPTOR_SIZE (mask) != 4)
    {
      if (GFC_DESCRIPTOR_SIZE (mask) != 8)
        runtime_error ("Funny sized logical array");
      for (n = 0; n < dim; n++)
        mstride[n] <<= 1;
      mstride0 <<= 1;
      mptr = GFOR_POINTER_L8_TO_L4 (mptr);
    }

  while (rptr)
    {
      if (*mptr)
        {
          /* From vector.  */
          memcpy (rptr, vptr, size);
          vptr += vstride0;
        }
      else
        {
          /* From field.  */
          memcpy (rptr, fptr, size);
        }
      /* 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];
            }
        }
    }
}

extern void unpack1 (gfc_array_char *, const gfc_array_char *,
		     const gfc_array_l4 *, const gfc_array_char *);
export_proto(unpack1);

void
unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
	 const gfc_array_l4 *mask, const gfc_array_char *field)
{
  unpack_internal (ret, vector, mask, field,
		   GFC_DESCRIPTOR_SIZE (vector),
		   GFC_DESCRIPTOR_SIZE (field));
}

extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
			  const gfc_array_char *, const gfc_array_l4 *,
			  const gfc_array_char *, GFC_INTEGER_4,
			  GFC_INTEGER_4);
export_proto(unpack1_char);

void
unpack1_char (gfc_array_char *ret,
	      GFC_INTEGER_4 ret_length __attribute__((unused)),
	      const gfc_array_char *vector, const gfc_array_l4 *mask,
	      const gfc_array_char *field, GFC_INTEGER_4 vector_length,
	      GFC_INTEGER_4 field_length)
{
  unpack_internal (ret, vector, mask, field, vector_length, field_length);
}

extern void unpack0 (gfc_array_char *, const gfc_array_char *,
		     const gfc_array_l4 *, char *);
export_proto(unpack0);

void
unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
	 const gfc_array_l4 *mask, char *field)
{
  gfc_array_char tmp;

  tmp.dtype = 0;
  tmp.data = field;
  unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0);
}

extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
			  const gfc_array_char *, const gfc_array_l4 *,
			  char *, GFC_INTEGER_4, GFC_INTEGER_4);
export_proto(unpack0_char);

void
unpack0_char (gfc_array_char *ret,
	      GFC_INTEGER_4 ret_length __attribute__((unused)),
	      const gfc_array_char *vector, const gfc_array_l4 *mask,
	      char *field, GFC_INTEGER_4 vector_length,
	      GFC_INTEGER_4 field_length __attribute__((unused)))
{
  gfc_array_char tmp;

  tmp.dtype = 0;
  tmp.data = field;
  unpack_internal (ret, vector, mask, &tmp, vector_length, 0);
}
Commit	Line	Data
	1	/* Generic implementation of the UNPACK intrinsic
	2	Copyright 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
	3	Contributed by Paul Brook <paul@nowt.org>
	4
	5	This file is part of the GNU Fortran 95 runtime library (libgfortran).
	6
	7	Libgfortran is free software; you can redistribute it and/or
	8	modify it under the terms of the GNU General Public
	9	License as published by the Free Software Foundation; either
	10	version 2 of the License, or (at your option) any later version.
	11
	12	In addition to the permissions in the GNU General Public License, the
	13	Free Software Foundation gives you unlimited permission to link the
	14	compiled version of this file into combinations with other programs,
	15	and to distribute those combinations without any restriction coming
	16	from the use of this file. (The General Public License restrictions
	17	do apply in other respects; for example, they cover modification of
	18	the file, and distribution when not linked into a combine
	19	executable.)
	20
	21	Ligbfortran is distributed in the hope that it will be useful,
	22	but WITHOUT ANY WARRANTY; without even the implied warranty of
	23	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	24	GNU General Public License for more details.
	25
	26	You should have received a copy of the GNU General Public
	27	License along with libgfortran; see the file COPYING. If not,
	28	write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
	29	Boston, MA 02110-1301, USA. */
	30
	31	#include "config.h"
	32	#include <stdlib.h>
	33	#include <assert.h>
	34	#include <string.h>
	35	#include "libgfortran.h"
	36
	37	static void
	38	unpack_internal (gfc_array_char ret, const gfc_array_char vector,
	39	const gfc_array_l4 mask, const gfc_array_char field,
	40	index_type size, index_type fsize)
	41	{
	42	/* r.* indicates the return array. */
	43	index_type rstride[GFC_MAX_DIMENSIONS];
	44	index_type rstride0;
	45	index_type rs;
	46	char *rptr;
	47	/* v.* indicates the vector array. */
	48	index_type vstride0;
	49	char *vptr;
	50	/* f.* indicates the field array. */
	51	index_type fstride[GFC_MAX_DIMENSIONS];
	52	index_type fstride0;
	53	const char *fptr;
	54	/* m.* indicates the mask array. */
	55	index_type mstride[GFC_MAX_DIMENSIONS];
	56	index_type mstride0;
	57	const GFC_LOGICAL_4 *mptr;
	58
	59	index_type count[GFC_MAX_DIMENSIONS];
	60	index_type extent[GFC_MAX_DIMENSIONS];
	61	index_type n;
	62	index_type dim;
	63
	64	if (ret->data == NULL)
	65	{
	66	/* The front end has signalled that we need to populate the
	67	return array descriptor. */
	68	dim = GFC_DESCRIPTOR_RANK (mask);
	69	rs = 1;
	70	for (n = 0; n < dim; n++)
	71	{
	72	count[n] = 0;
	73	ret->dim[n].stride = rs;
	74	ret->dim[n].lbound = 0;
	75	ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
	76	extent[n] = ret->dim[n].ubound + 1;
	77	rstride[n] = ret->dim[n].stride * size;
	78	fstride[n] = field->dim[n].stride * fsize;
	79	mstride[n] = mask->dim[n].stride;
	80	rs *= extent[n];
	81	}
	82	ret->offset = 0;
	83	ret->data = internal_malloc_size (rs * size);
	84	}
	85	else
	86	{
	87	dim = GFC_DESCRIPTOR_RANK (ret);
	88	for (n = 0; n < dim; n++)
	89	{
	90	count[n] = 0;
	91	extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
	92	rstride[n] = ret->dim[n].stride * size;
	93	fstride[n] = field->dim[n].stride * fsize;
	94	mstride[n] = mask->dim[n].stride;
	95	}
	96	if (rstride[0] == 0)
	97	rstride[0] = size;
	98	}
	99	if (fstride[0] == 0)
	100	fstride[0] = fsize;
	101	if (mstride[0] == 0)
	102	mstride[0] = 1;
	103
	104	vstride0 = vector->dim[0].stride * size;
	105	if (vstride0 == 0)
	106	vstride0 = size;
	107	rstride0 = rstride[0];
	108	fstride0 = fstride[0];
	109	mstride0 = mstride[0];
	110	rptr = ret->data;
	111	fptr = field->data;
	112	mptr = mask->data;
	113	vptr = vector->data;
	114
	115	/* Use the same loop for both logical types. */
	116	if (GFC_DESCRIPTOR_SIZE (mask) != 4)
	117	{
	118	if (GFC_DESCRIPTOR_SIZE (mask) != 8)
	119	runtime_error ("Funny sized logical array");
	120	for (n = 0; n < dim; n++)
	121	mstride[n] <<= 1;
	122	mstride0 <<= 1;
	123	mptr = GFOR_POINTER_L8_TO_L4 (mptr);
	124	}
	125
	126	while (rptr)
	127	{
	128	if (*mptr)
	129	{
	130	/* From vector. */
	131	memcpy (rptr, vptr, size);
	132	vptr += vstride0;
	133	}
	134	else
	135	{
	136	/* From field. */
	137	memcpy (rptr, fptr, size);
	138	}
	139	/* Advance to the next element. */
	140	rptr += rstride0;
	141	fptr += fstride0;
	142	mptr += mstride0;
	143	count[0]++;
	144	n = 0;
	145	while (count[n] == extent[n])
	146	{
	147	/* When we get to the end of a dimension, reset it and increment
	148	the next dimension. */
	149	count[n] = 0;
	150	/* We could precalculate these products, but this is a less
	151	frequently used path so probably not worth it. */
	152	rptr -= rstride[n] * extent[n];
	153	fptr -= fstride[n] * extent[n];
	154	mptr -= mstride[n] * extent[n];
	155	n++;
	156	if (n >= dim)
	157	{
	158	/* Break out of the loop. */
	159	rptr = NULL;
	160	break;
	161	}
	162	else
	163	{
	164	count[n]++;
	165	rptr += rstride[n];
	166	fptr += fstride[n];
	167	mptr += mstride[n];
	168	}
	169	}
	170	}
	171	}
	172
	173	extern void unpack1 (gfc_array_char , const gfc_array_char ,
	174	const gfc_array_l4 , const gfc_array_char );
	175	export_proto(unpack1);
	176
	177	void
	178	unpack1 (gfc_array_char ret, const gfc_array_char vector,
	179	const gfc_array_l4 mask, const gfc_array_char field)
	180	{
	181	unpack_internal (ret, vector, mask, field,
	182	GFC_DESCRIPTOR_SIZE (vector),
	183	GFC_DESCRIPTOR_SIZE (field));
	184	}
	185
	186	extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
	187	const gfc_array_char , const gfc_array_l4 ,
	188	const gfc_array_char *, GFC_INTEGER_4,
	189	GFC_INTEGER_4);
	190	export_proto(unpack1_char);
	191
	192	void
	193	unpack1_char (gfc_array_char *ret,
	194	GFC_INTEGER_4 ret_length __attribute__((unused)),
	195	const gfc_array_char vector, const gfc_array_l4 mask,
	196	const gfc_array_char *field, GFC_INTEGER_4 vector_length,
	197	GFC_INTEGER_4 field_length)
	198	{
	199	unpack_internal (ret, vector, mask, field, vector_length, field_length);
	200	}
	201
	202	extern void unpack0 (gfc_array_char , const gfc_array_char ,
	203	const gfc_array_l4 , char );
	204	export_proto(unpack0);
	205
	206	void
	207	unpack0 (gfc_array_char ret, const gfc_array_char vector,
	208	const gfc_array_l4 mask, char field)
	209	{
	210	gfc_array_char tmp;
	211
	212	tmp.dtype = 0;
	213	tmp.data = field;
	214	unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0);
	215	}
	216
	217	extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
	218	const gfc_array_char , const gfc_array_l4 ,
	219	char *, GFC_INTEGER_4, GFC_INTEGER_4);
	220	export_proto(unpack0_char);
	221
	222	void
	223	unpack0_char (gfc_array_char *ret,
	224	GFC_INTEGER_4 ret_length __attribute__((unused)),
	225	const gfc_array_char vector, const gfc_array_l4 mask,
	226	char *field, GFC_INTEGER_4 vector_length,
	227	GFC_INTEGER_4 field_length __attribute__((unused)))
	228	{
	229	gfc_array_char tmp;
	230
	231	tmp.dtype = 0;
	232	tmp.data = field;
	233	unpack_internal (ret, vector, mask, &tmp, vector_length, 0);
	234	}