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

/* Generic implementation of the UNPACK intrinsic
   Copyright 2002, 2003, 2004, 2005, 2007 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 "libgfortran.h"
#include <stdlib.h>
#include <assert.h>
#include <string.h>

static void
unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
		 const gfc_array_l1 *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 * restrict 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_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->data;

  /* 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
      )
    {
      /*  Don't 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->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;
	  empty = empty || extent[n] <= 0;
	  rstride[n] = ret->dim[n].stride * size;
	  fstride[n] = field->dim[n].stride * fsize;
	  mstride[n] = mask->dim[n].stride * mask_kind;
	  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;
	  empty = empty || extent[n] <= 0;
	  rstride[n] = ret->dim[n].stride * size;
	  fstride[n] = field->dim[n].stride * fsize;
	  mstride[n] = mask->dim[n].stride * mask_kind;
	}
      if (rstride[0] == 0)
	rstride[0] = size;
    }

  if (empty)
    return;

  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;
  vptr = vector->data;

  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_l1 *, const gfc_array_char *);
export_proto(unpack1);

void
unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
	 const gfc_array_l1 *mask, const gfc_array_char *field)
{
  index_type type_size;
  index_type size;

  type_size = GFC_DTYPE_TYPE_SIZE (vector);
  size = GFC_DESCRIPTOR_SIZE (vector);

  switch(type_size)
    {
    case GFC_DTYPE_LOGICAL_1:
    case GFC_DTYPE_INTEGER_1:
    case GFC_DTYPE_DERIVED_1:
      unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
		  mask, (gfc_array_i1 *) field);
      return;

    case GFC_DTYPE_LOGICAL_2:
    case GFC_DTYPE_INTEGER_2:
      unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
		  mask, (gfc_array_i2 *) field);
      return;

    case GFC_DTYPE_LOGICAL_4:
    case GFC_DTYPE_INTEGER_4:
      unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
		  mask, (gfc_array_i4 *) field);
      return;

    case GFC_DTYPE_LOGICAL_8:
    case GFC_DTYPE_INTEGER_8:
      unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
		  mask, (gfc_array_i8 *) field);
      return;

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_LOGICAL_16:
    case GFC_DTYPE_INTEGER_16:
      unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
		   mask, (gfc_array_i16 *) field);
      return;
#endif
    case GFC_DTYPE_REAL_4:
      unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
		  mask, (gfc_array_r4 *) field);
      return;

    case GFC_DTYPE_REAL_8:
      unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector,
		  mask, (gfc_array_r8 *) field);
      return;

#ifdef HAVE_GFC_REAL_10
    case GFC_DTYPE_REAL_10:
      unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
		   mask, (gfc_array_r10 *) field);
	  return;
#endif

#ifdef HAVE_GFC_REAL_16
    case GFC_DTYPE_REAL_16:
      unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
		   mask, (gfc_array_r16 *) field);
      return;
#endif

    case GFC_DTYPE_COMPLEX_4:
      unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
		  mask, (gfc_array_c4 *) field);
      return;

    case GFC_DTYPE_COMPLEX_8:
      unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
		  mask, (gfc_array_c8 *) field);
      return;

#ifdef HAVE_GFC_COMPLEX_10
    case GFC_DTYPE_COMPLEX_10:
      unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
		   mask, (gfc_array_c10 *) field);
      return;
#endif

#ifdef HAVE_GFC_COMPLEX_16
    case GFC_DTYPE_COMPLEX_16:
      unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
		   mask, (gfc_array_c16 *) field);
      return;
#endif

    case GFC_DTYPE_DERIVED_2:
      if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
	  || GFC_UNALIGNED_2(field->data))
	break;
      else
	{
	  unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
		      mask, (gfc_array_i2 *) field);
	  return;
	}

    case GFC_DTYPE_DERIVED_4:
      if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
	  || GFC_UNALIGNED_4(field->data))
	break;
      else
	{
	  unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
		      mask, (gfc_array_i4 *) field);
	  return;
	}

    case GFC_DTYPE_DERIVED_8:
      if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
	  || GFC_UNALIGNED_8(field->data))
	break;
      else
	{
	  unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
		      mask, (gfc_array_i8 *) field);
	  return;
	}

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_DERIVED_16:
      if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
	  || GFC_UNALIGNED_16(field->data))
	break;
      else
	{
	  unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
		       mask, (gfc_array_i16 *) field);
	  return;
	}
#endif
    }

  unpack_internal (ret, vector, mask, field, size,
		   GFC_DESCRIPTOR_SIZE (field));
}


extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
			  const gfc_array_char *, const gfc_array_l1 *,
			  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_l1 *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 unpack1_char4 (gfc_array_char *, GFC_INTEGER_4,
			   const gfc_array_char *, const gfc_array_l1 *,
			   const gfc_array_char *, GFC_INTEGER_4,
			   GFC_INTEGER_4);
export_proto(unpack1_char4);

void
unpack1_char4 (gfc_array_char *ret,
	       GFC_INTEGER_4 ret_length __attribute__((unused)),
	       const gfc_array_char *vector, const gfc_array_l1 *mask,
	       const gfc_array_char *field, GFC_INTEGER_4 vector_length,
	       GFC_INTEGER_4 field_length)
{
  unpack_internal (ret, vector, mask, field,
		   vector_length * sizeof (gfc_char4_t),
		   field_length * sizeof (gfc_char4_t));
}


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

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

  index_type type_size;
  index_type size;

  type_size = GFC_DTYPE_TYPE_SIZE (vector);
  size = GFC_DESCRIPTOR_SIZE (vector);

  switch(type_size)
    {
    case GFC_DTYPE_LOGICAL_1:
    case GFC_DTYPE_INTEGER_1:
    case GFC_DTYPE_DERIVED_1:
      unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
		  mask, (GFC_INTEGER_1 *) field);
      return;

    case GFC_DTYPE_LOGICAL_2:
    case GFC_DTYPE_INTEGER_2:
      unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
		  mask, (GFC_INTEGER_2 *) field);
      return;

    case GFC_DTYPE_LOGICAL_4:
    case GFC_DTYPE_INTEGER_4:
      unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
		  mask, (GFC_INTEGER_4 *) field);
      return;

    case GFC_DTYPE_LOGICAL_8:
    case GFC_DTYPE_INTEGER_8:
      unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
		  mask, (GFC_INTEGER_8 *) field);
      return;

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_LOGICAL_16:
    case GFC_DTYPE_INTEGER_16:
      unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
		   mask, (GFC_INTEGER_16 *) field);
      return;
#endif
    case GFC_DTYPE_REAL_4:
      unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
		  mask, (GFC_REAL_4 *) field);
      return;

    case GFC_DTYPE_REAL_8:
      unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
		  mask, (GFC_REAL_8  *) field);
      return;

#ifdef HAVE_GFC_REAL_10
    case GFC_DTYPE_REAL_10:
      unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
		   mask, (GFC_REAL_10 *) field);
      return;
#endif

#ifdef HAVE_GFC_REAL_16
    case GFC_DTYPE_REAL_16:
      unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
		   mask, (GFC_REAL_16 *) field);
      return;
#endif

    case GFC_DTYPE_COMPLEX_4:
      unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
		  mask, (GFC_COMPLEX_4 *) field);
      return;

    case GFC_DTYPE_COMPLEX_8:
      unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
		  mask, (GFC_COMPLEX_8 *) field);
      return;

#ifdef HAVE_GFC_COMPLEX_10
    case GFC_DTYPE_COMPLEX_10:
      unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
		   mask, (GFC_COMPLEX_10 *) field);
      return;
#endif

#ifdef HAVE_GFC_COMPLEX_16
    case GFC_DTYPE_COMPLEX_16:
      unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
		   mask, (GFC_COMPLEX_16 *) field);
      return;
#endif
    case GFC_DTYPE_DERIVED_2:
      if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
	  || GFC_UNALIGNED_2(field))
	break;
      else
	{
	  unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
		      mask, (GFC_INTEGER_2 *) field);
	  return;
	}

    case GFC_DTYPE_DERIVED_4:
      if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
	  || GFC_UNALIGNED_4(field))
	break;
      else
	{
	  unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
		      mask, (GFC_INTEGER_4 *) field);
	  return;
	}

    case GFC_DTYPE_DERIVED_8:
      if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
	  || GFC_UNALIGNED_8(field))
	break;
      else
	{
	  unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
		      mask, (GFC_INTEGER_8 *) field);
	  return;
	}
#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_DERIVED_16:
      if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
	  || GFC_UNALIGNED_16(field))
	break;
      else
	{
	  unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
		       mask, (GFC_INTEGER_16 *) field);
	  return;
	}
#endif
    }

  memset (&tmp, 0, sizeof (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_l1 *,
			  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_l1 *mask,
	      char *field, GFC_INTEGER_4 vector_length,
	      GFC_INTEGER_4 field_length __attribute__((unused)))
{
  gfc_array_char tmp;

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


extern void unpack0_char4 (gfc_array_char *, GFC_INTEGER_4,
			   const gfc_array_char *, const gfc_array_l1 *,
			   char *, GFC_INTEGER_4, GFC_INTEGER_4);
export_proto(unpack0_char4);

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

  memset (&tmp, 0, sizeof (tmp));
  tmp.dtype = 0;
  tmp.data = field;
  unpack_internal (ret, vector, mask, &tmp,
		   vector_length * sizeof (gfc_char4_t), 0);
}
Commit	Line	Data
ba4a3d54	1	/* Generic implementation of the UNPACK intrinsic
36ae8a61	2	Copyright 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc.
6de9cd9a DN	3	Contributed by Paul Brook <paul@nowt.org>
6de9cd9a DN	4
57dea9f6	5	This file is part of the GNU Fortran 95 runtime library (libgfortran).
6de9cd9a	6
57dea9f6 TM	7	Libgfortran is free software; you can redistribute it and/or
57dea9f6 TM	8	modify it under the terms of the GNU General Public
6de9cd9a	9	License as published by the Free Software Foundation; either
57dea9f6	10	version 2 of the License, or (at your option) any later version.
6de9cd9a	11
57dea9f6 TM	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,
6de9cd9a DN	22	but WITHOUT ANY WARRANTY; without even the implied warranty of
6de9cd9a DN	23	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
57dea9f6	24	GNU General Public License for more details.
6de9cd9a	25
57dea9f6 TM	26	You should have received a copy of the GNU General Public
57dea9f6 TM	27	License along with libgfortran; see the file COPYING. If not,
fe2ae685 KC	28	write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
fe2ae685 KC	29	Boston, MA 02110-1301, USA. */
6de9cd9a	30
36ae8a61	31	#include "libgfortran.h"
6de9cd9a DN	32	#include <stdlib.h>
	33	#include <assert.h>
	34	#include <string.h>
6de9cd9a	35
7823229b RS	36	static void
7823229b RS	37	unpack_internal (gfc_array_char ret, const gfc_array_char vector,
28dc6b33	38	const gfc_array_l1 mask, const gfc_array_char field,
7823229b	39	index_type size, index_type fsize)
6de9cd9a DN	40	{
	41	/* r.* indicates the return array. */
	42	index_type rstride[GFC_MAX_DIMENSIONS];
	43	index_type rstride0;
ba4a3d54	44	index_type rs;
5863aacf	45	char * restrict rptr;
6de9cd9a DN	46	/* v.* indicates the vector array. */
	47	index_type vstride0;
	48	char *vptr;
	49	/* f.* indicates the field array. */
	50	index_type fstride[GFC_MAX_DIMENSIONS];
	51	index_type fstride0;
	52	const char *fptr;
	53	/* m.* indicates the mask array. */
	54	index_type mstride[GFC_MAX_DIMENSIONS];
	55	index_type mstride0;
28dc6b33	56	const GFC_LOGICAL_1 *mptr;
6de9cd9a DN	57
	58	index_type count[GFC_MAX_DIMENSIONS];
	59	index_type extent[GFC_MAX_DIMENSIONS];
	60	index_type n;
	61	index_type dim;
6de9cd9a	62
fb263f82	63	int empty;
28dc6b33	64	int mask_kind;
fb263f82 TK	65
fb263f82 TK	66	empty = 0;
28dc6b33 TK	67
	68	mptr = mask->data;
	69
	70	/* Use the same loop for all logical types, by using GFC_LOGICAL_1
	71	and using shifting to address size and endian issues. */
	72
	73	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	74
	75	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	76	#ifdef HAVE_GFC_LOGICAL_16
	77	\|\| mask_kind == 16
	78	#endif
	79	)
	80	{
	81	/* Don't convert a NULL pointer as we use test for NULL below. */
	82	if (mptr)
	83	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
	84	}
	85	else
	86	runtime_error ("Funny sized logical array");
	87
ba4a3d54	88	if (ret->data == NULL)
6de9cd9a	89	{
ba4a3d54 TK	90	/* The front end has signalled that we need to populate the
	91	return array descriptor. */
	92	dim = GFC_DESCRIPTOR_RANK (mask);
	93	rs = 1;
	94	for (n = 0; n < dim; n++)
	95	{
	96	count[n] = 0;
	97	ret->dim[n].stride = rs;
	98	ret->dim[n].lbound = 0;
	99	ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
	100	extent[n] = ret->dim[n].ubound + 1;
fb263f82	101	empty = empty \|\| extent[n] <= 0;
ba4a3d54 TK	102	rstride[n] = ret->dim[n].stride * size;
ba4a3d54 TK	103	fstride[n] = field->dim[n].stride * fsize;
28dc6b33	104	mstride[n] = mask->dim[n].stride * mask_kind;
ba4a3d54 TK	105	rs *= extent[n];
ba4a3d54 TK	106	}
efd4dc1a	107	ret->offset = 0;
ba4a3d54 TK	108	ret->data = internal_malloc_size (rs * size);
	109	}
	110	else
	111	{
	112	dim = GFC_DESCRIPTOR_RANK (ret);
	113	for (n = 0; n < dim; n++)
	114	{
	115	count[n] = 0;
	116	extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
fb263f82	117	empty = empty \|\| extent[n] <= 0;
ba4a3d54 TK	118	rstride[n] = ret->dim[n].stride * size;
ba4a3d54 TK	119	fstride[n] = field->dim[n].stride * fsize;
28dc6b33	120	mstride[n] = mask->dim[n].stride * mask_kind;
ba4a3d54 TK	121	}
	122	if (rstride[0] == 0)
	123	rstride[0] = size;
6de9cd9a	124	}
fb263f82 TK	125
	126	if (empty)
	127	return;
	128
6de9cd9a DN	129	if (fstride[0] == 0)
	130	fstride[0] = fsize;
	131	if (mstride[0] == 0)
	132	mstride[0] = 1;
	133
	134	vstride0 = vector->dim[0].stride * size;
	135	if (vstride0 == 0)
	136	vstride0 = size;
	137	rstride0 = rstride[0];
	138	fstride0 = fstride[0];
	139	mstride0 = mstride[0];
	140	rptr = ret->data;
	141	fptr = field->data;
6de9cd9a DN	142	vptr = vector->data;
6de9cd9a DN	143
6de9cd9a DN	144	while (rptr)
	145	{
	146	if (*mptr)
	147	{
	148	/* From vector. */
	149	memcpy (rptr, vptr, size);
	150	vptr += vstride0;
	151	}
	152	else
	153	{
	154	/* From field. */
	155	memcpy (rptr, fptr, size);
	156	}
	157	/* Advance to the next element. */
	158	rptr += rstride0;
	159	fptr += fstride0;
	160	mptr += mstride0;
	161	count[0]++;
	162	n = 0;
	163	while (count[n] == extent[n])
	164	{
	165	/* When we get to the end of a dimension, reset it and increment
	166	the next dimension. */
	167	count[n] = 0;
	168	/* We could precalculate these products, but this is a less
8b6dba81	169	frequently used path so probably not worth it. */
6de9cd9a DN	170	rptr -= rstride[n] * extent[n];
	171	fptr -= fstride[n] * extent[n];
	172	mptr -= mstride[n] * extent[n];
	173	n++;
	174	if (n >= dim)
	175	{
	176	/* Break out of the loop. */
	177	rptr = NULL;
	178	break;
	179	}
	180	else
	181	{
	182	count[n]++;
	183	rptr += rstride[n];
	184	fptr += fstride[n];
	185	mptr += mstride[n];
	186	}
	187	}
	188	}
	189	}
7823229b RS	190
7823229b RS	191	extern void unpack1 (gfc_array_char , const gfc_array_char ,
e6082041	192	const gfc_array_l1 , const gfc_array_char );
7823229b RS	193	export_proto(unpack1);
	194
	195	void
	196	unpack1 (gfc_array_char ret, const gfc_array_char vector,
e6082041	197	const gfc_array_l1 mask, const gfc_array_char field)
7823229b	198	{
c7d0f4d5	199	index_type type_size;
3478bba4 TK	200	index_type size;
3478bba4 TK	201
c7d0f4d5	202	type_size = GFC_DTYPE_TYPE_SIZE (vector);
3478bba4 TK	203	size = GFC_DESCRIPTOR_SIZE (vector);
3478bba4 TK	204
c7d0f4d5	205	switch(type_size)
3478bba4	206	{
c7d0f4d5 TK	207	case GFC_DTYPE_LOGICAL_1:
	208	case GFC_DTYPE_INTEGER_1:
	209	case GFC_DTYPE_DERIVED_1:
	210	unpack1_i1 ((gfc_array_i1 ) ret, (gfc_array_i1 ) vector,
	211	mask, (gfc_array_i1 *) field);
	212	return;
	213
	214	case GFC_DTYPE_LOGICAL_2:
	215	case GFC_DTYPE_INTEGER_2:
	216	unpack1_i2 ((gfc_array_i2 ) ret, (gfc_array_i2 ) vector,
	217	mask, (gfc_array_i2 *) field);
	218	return;
	219
	220	case GFC_DTYPE_LOGICAL_4:
	221	case GFC_DTYPE_INTEGER_4:
	222	unpack1_i4 ((gfc_array_i4 ) ret, (gfc_array_i4 ) vector,
	223	mask, (gfc_array_i4 *) field);
	224	return;
	225
	226	case GFC_DTYPE_LOGICAL_8:
	227	case GFC_DTYPE_INTEGER_8:
	228	unpack1_i8 ((gfc_array_i8 ) ret, (gfc_array_i8 ) vector,
	229	mask, (gfc_array_i8 *) field);
	230	return;
3478bba4 TK	231
3478bba4 TK	232	#ifdef HAVE_GFC_INTEGER_16
c7d0f4d5 TK	233	case GFC_DTYPE_LOGICAL_16:
	234	case GFC_DTYPE_INTEGER_16:
	235	unpack1_i16 ((gfc_array_i16 ) ret, (gfc_array_i16 ) vector,
	236	mask, (gfc_array_i16 *) field);
	237	return;
3478bba4	238	#endif
c7d0f4d5 TK	239	case GFC_DTYPE_REAL_4:
	240	unpack1_r4 ((gfc_array_r4 ) ret, (gfc_array_r4 ) vector,
	241	mask, (gfc_array_r4 *) field);
	242	return;
3478bba4	243
c7d0f4d5 TK	244	case GFC_DTYPE_REAL_8:
	245	unpack1_r8 ((gfc_array_r8 ) ret, (gfc_array_r8 ) vector,
	246	mask, (gfc_array_r8 *) field);
	247	return;
3478bba4 TK	248
3478bba4 TK	249	#ifdef HAVE_GFC_REAL_10
c7d0f4d5 TK	250	case GFC_DTYPE_REAL_10:
	251	unpack1_r10 ((gfc_array_r10 ) ret, (gfc_array_r10 ) vector,
	252	mask, (gfc_array_r10 *) field);
3478bba4 TK	253	return;
	254	#endif
	255
	256	#ifdef HAVE_GFC_REAL_16
c7d0f4d5 TK	257	case GFC_DTYPE_REAL_16:
	258	unpack1_r16 ((gfc_array_r16 ) ret, (gfc_array_r16 ) vector,
	259	mask, (gfc_array_r16 *) field);
	260	return;
3478bba4	261	#endif
3478bba4	262
c7d0f4d5 TK	263	case GFC_DTYPE_COMPLEX_4:
	264	unpack1_c4 ((gfc_array_c4 ) ret, (gfc_array_c4 ) vector,
	265	mask, (gfc_array_c4 *) field);
	266	return;
3478bba4	267
c7d0f4d5 TK	268	case GFC_DTYPE_COMPLEX_8:
	269	unpack1_c8 ((gfc_array_c8 ) ret, (gfc_array_c8 ) vector,
	270	mask, (gfc_array_c8 *) field);
	271	return;
3478bba4 TK	272
3478bba4 TK	273	#ifdef HAVE_GFC_COMPLEX_10
c7d0f4d5 TK	274	case GFC_DTYPE_COMPLEX_10:
	275	unpack1_c10 ((gfc_array_c10 ) ret, (gfc_array_c10 ) vector,
	276	mask, (gfc_array_c10 *) field);
	277	return;
3478bba4 TK	278	#endif
	279
	280	#ifdef HAVE_GFC_COMPLEX_16
c7d0f4d5 TK	281	case GFC_DTYPE_COMPLEX_16:
	282	unpack1_c16 ((gfc_array_c16 ) ret, (gfc_array_c16 ) vector,
	283	mask, (gfc_array_c16 *) field);
	284	return;
3478bba4	285	#endif
c7d0f4d5 TK	286
	287	case GFC_DTYPE_DERIVED_2:
	288	if (GFC_UNALIGNED_2(ret->data) \|\| GFC_UNALIGNED_2(vector->data)
	289	\|\| GFC_UNALIGNED_2(field->data))
	290	break;
	291	else
	292	{
	293	unpack1_i2 ((gfc_array_i2 ) ret, (gfc_array_i2 ) vector,
	294	mask, (gfc_array_i2 *) field);
	295	return;
	296	}
	297
	298	case GFC_DTYPE_DERIVED_4:
	299	if (GFC_UNALIGNED_4(ret->data) \|\| GFC_UNALIGNED_4(vector->data)
	300	\|\| GFC_UNALIGNED_4(field->data))
	301	break;
	302	else
	303	{
	304	unpack1_i4 ((gfc_array_i4 ) ret, (gfc_array_i4 ) vector,
	305	mask, (gfc_array_i4 *) field);
	306	return;
	307	}
	308
	309	case GFC_DTYPE_DERIVED_8:
	310	if (GFC_UNALIGNED_8(ret->data) \|\| GFC_UNALIGNED_8(vector->data)
	311	\|\| GFC_UNALIGNED_8(field->data))
	312	break;
	313	else
	314	{
	315	unpack1_i8 ((gfc_array_i8 ) ret, (gfc_array_i8 ) vector,
	316	mask, (gfc_array_i8 *) field);
	317	return;
3478bba4 TK	318	}
3478bba4 TK	319
c7d0f4d5 TK	320	#ifdef HAVE_GFC_INTEGER_16
	321	case GFC_DTYPE_DERIVED_16:
	322	if (GFC_UNALIGNED_16(ret->data) \|\| GFC_UNALIGNED_16(vector->data)
	323	\|\| GFC_UNALIGNED_16(field->data))
	324	break;
	325	else
	326	{
	327	unpack1_i16 ((gfc_array_i16 ) ret, (gfc_array_i16 ) vector,
	328	mask, (gfc_array_i16 *) field);
	329	return;
	330	}
	331	#endif
3478bba4	332	}
c7d0f4d5	333
3478bba4	334	unpack_internal (ret, vector, mask, field, size,
7823229b RS	335	GFC_DESCRIPTOR_SIZE (field));
	336	}
	337
3571925e	338
7823229b	339	extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
e6082041	340	const gfc_array_char , const gfc_array_l1 ,
7823229b RS	341	const gfc_array_char *, GFC_INTEGER_4,
	342	GFC_INTEGER_4);
	343	export_proto(unpack1_char);
	344
	345	void
	346	unpack1_char (gfc_array_char *ret,
	347	GFC_INTEGER_4 ret_length __attribute__((unused)),
e6082041	348	const gfc_array_char vector, const gfc_array_l1 mask,
7823229b RS	349	const gfc_array_char *field, GFC_INTEGER_4 vector_length,
	350	GFC_INTEGER_4 field_length)
	351	{
	352	unpack_internal (ret, vector, mask, field, vector_length, field_length);
	353	}
6de9cd9a	354
3571925e FXC	355
	356	extern void unpack1_char4 (gfc_array_char *, GFC_INTEGER_4,
	357	const gfc_array_char , const gfc_array_l1 ,
	358	const gfc_array_char *, GFC_INTEGER_4,
	359	GFC_INTEGER_4);
	360	export_proto(unpack1_char4);
	361
	362	void
	363	unpack1_char4 (gfc_array_char *ret,
	364	GFC_INTEGER_4 ret_length __attribute__((unused)),
	365	const gfc_array_char vector, const gfc_array_l1 mask,
	366	const gfc_array_char *field, GFC_INTEGER_4 vector_length,
	367	GFC_INTEGER_4 field_length)
	368	{
	369	unpack_internal (ret, vector, mask, field,
	370	vector_length * sizeof (gfc_char4_t),
	371	field_length * sizeof (gfc_char4_t));
	372	}
	373
	374
a3b6aba2	375	extern void unpack0 (gfc_array_char , const gfc_array_char ,
e6082041	376	const gfc_array_l1 , char );
7f68c75f	377	export_proto(unpack0);
7d7b8bfe	378
6de9cd9a	379	void
a3b6aba2	380	unpack0 (gfc_array_char ret, const gfc_array_char vector,
e6082041	381	const gfc_array_l1 mask, char field)
6de9cd9a DN	382	{
	383	gfc_array_char tmp;
	384
c7d0f4d5	385	index_type type_size;
3478bba4 TK	386	index_type size;
3478bba4 TK	387
c7d0f4d5	388	type_size = GFC_DTYPE_TYPE_SIZE (vector);
3478bba4 TK	389	size = GFC_DESCRIPTOR_SIZE (vector);
3478bba4 TK	390
c7d0f4d5	391	switch(type_size)
3478bba4	392	{
c7d0f4d5 TK	393	case GFC_DTYPE_LOGICAL_1:
	394	case GFC_DTYPE_INTEGER_1:
	395	case GFC_DTYPE_DERIVED_1:
	396	unpack0_i1 ((gfc_array_i1 ) ret, (gfc_array_i1 ) vector,
	397	mask, (GFC_INTEGER_1 *) field);
	398	return;
	399
	400	case GFC_DTYPE_LOGICAL_2:
	401	case GFC_DTYPE_INTEGER_2:
	402	unpack0_i2 ((gfc_array_i2 ) ret, (gfc_array_i2 ) vector,
	403	mask, (GFC_INTEGER_2 *) field);
	404	return;
	405
	406	case GFC_DTYPE_LOGICAL_4:
	407	case GFC_DTYPE_INTEGER_4:
	408	unpack0_i4 ((gfc_array_i4 ) ret, (gfc_array_i4 ) vector,
	409	mask, (GFC_INTEGER_4 *) field);
	410	return;
	411
	412	case GFC_DTYPE_LOGICAL_8:
	413	case GFC_DTYPE_INTEGER_8:
	414	unpack0_i8 ((gfc_array_i8 ) ret, (gfc_array_i8 ) vector,
	415	mask, (GFC_INTEGER_8 *) field);
	416	return;
3478bba4 TK	417
3478bba4 TK	418	#ifdef HAVE_GFC_INTEGER_16
c7d0f4d5 TK	419	case GFC_DTYPE_LOGICAL_16:
	420	case GFC_DTYPE_INTEGER_16:
	421	unpack0_i16 ((gfc_array_i16 ) ret, (gfc_array_i16 ) vector,
	422	mask, (GFC_INTEGER_16 *) field);
	423	return;
3478bba4	424	#endif
c7d0f4d5 TK	425	case GFC_DTYPE_REAL_4:
	426	unpack0_r4 ((gfc_array_r4 ) ret, (gfc_array_r4 ) vector,
	427	mask, (GFC_REAL_4 *) field);
	428	return;
3478bba4	429
c7d0f4d5 TK	430	case GFC_DTYPE_REAL_8:
	431	unpack0_r8 ((gfc_array_r8 ) ret, (gfc_array_r8) vector,
	432	mask, (GFC_REAL_8 *) field);
	433	return;
3478bba4 TK	434
3478bba4 TK	435	#ifdef HAVE_GFC_REAL_10
c7d0f4d5 TK	436	case GFC_DTYPE_REAL_10:
	437	unpack0_r10 ((gfc_array_r10 ) ret, (gfc_array_r10 ) vector,
	438	mask, (GFC_REAL_10 *) field);
	439	return;
3478bba4 TK	440	#endif
	441
	442	#ifdef HAVE_GFC_REAL_16
c7d0f4d5 TK	443	case GFC_DTYPE_REAL_16:
	444	unpack0_r16 ((gfc_array_r16 ) ret, (gfc_array_r16 ) vector,
	445	mask, (GFC_REAL_16 *) field);
	446	return;
3478bba4	447	#endif
3478bba4	448
c7d0f4d5 TK	449	case GFC_DTYPE_COMPLEX_4:
	450	unpack0_c4 ((gfc_array_c4 ) ret, (gfc_array_c4 ) vector,
	451	mask, (GFC_COMPLEX_4 *) field);
	452	return;
3478bba4	453
c7d0f4d5 TK	454	case GFC_DTYPE_COMPLEX_8:
	455	unpack0_c8 ((gfc_array_c8 ) ret, (gfc_array_c8 ) vector,
	456	mask, (GFC_COMPLEX_8 *) field);
	457	return;
3478bba4 TK	458
3478bba4 TK	459	#ifdef HAVE_GFC_COMPLEX_10
c7d0f4d5 TK	460	case GFC_DTYPE_COMPLEX_10:
	461	unpack0_c10 ((gfc_array_c10 ) ret, (gfc_array_c10 ) vector,
	462	mask, (GFC_COMPLEX_10 *) field);
	463	return;
3478bba4 TK	464	#endif
	465
	466	#ifdef HAVE_GFC_COMPLEX_16
c7d0f4d5 TK	467	case GFC_DTYPE_COMPLEX_16:
	468	unpack0_c16 ((gfc_array_c16 ) ret, (gfc_array_c16 ) vector,
	469	mask, (GFC_COMPLEX_16 *) field);
	470	return;
3478bba4	471	#endif
c7d0f4d5 TK	472	case GFC_DTYPE_DERIVED_2:
	473	if (GFC_UNALIGNED_2(ret->data) \|\| GFC_UNALIGNED_2(vector->data)
	474	\|\| GFC_UNALIGNED_2(field))
	475	break;
	476	else
	477	{
	478	unpack0_i2 ((gfc_array_i2 ) ret, (gfc_array_i2 ) vector,
	479	mask, (GFC_INTEGER_2 *) field);
	480	return;
	481	}
	482
	483	case GFC_DTYPE_DERIVED_4:
	484	if (GFC_UNALIGNED_4(ret->data) \|\| GFC_UNALIGNED_4(vector->data)
	485	\|\| GFC_UNALIGNED_4(field))
	486	break;
	487	else
	488	{
	489	unpack0_i4 ((gfc_array_i4 ) ret, (gfc_array_i4 ) vector,
	490	mask, (GFC_INTEGER_4 *) field);
	491	return;
	492	}
	493
	494	case GFC_DTYPE_DERIVED_8:
	495	if (GFC_UNALIGNED_8(ret->data) \|\| GFC_UNALIGNED_8(vector->data)
	496	\|\| GFC_UNALIGNED_8(field))
	497	break;
	498	else
	499	{
	500	unpack0_i8 ((gfc_array_i8 ) ret, (gfc_array_i8 ) vector,
	501	mask, (GFC_INTEGER_8 *) field);
	502	return;
	503	}
	504	#ifdef HAVE_GFC_INTEGER_16
	505	case GFC_DTYPE_DERIVED_16:
	506	if (GFC_UNALIGNED_16(ret->data) \|\| GFC_UNALIGNED_16(vector->data)
	507	\|\| GFC_UNALIGNED_16(field))
	508	break;
	509	else
	510	{
	511	unpack0_i16 ((gfc_array_i16 ) ret, (gfc_array_i16 ) vector,
	512	mask, (GFC_INTEGER_16 *) field);
	513	return;
3478bba4	514	}
c7d0f4d5	515	#endif
3478bba4	516	}
c7d0f4d5	517
c6e75626	518	memset (&tmp, 0, sizeof (tmp));
6de9cd9a DN	519	tmp.dtype = 0;
6de9cd9a DN	520	tmp.data = field;
7823229b RS	521	unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0);
	522	}
	523
3571925e	524
7823229b	525	extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
e6082041	526	const gfc_array_char , const gfc_array_l1 ,
7823229b RS	527	char *, GFC_INTEGER_4, GFC_INTEGER_4);
	528	export_proto(unpack0_char);
	529
	530	void
	531	unpack0_char (gfc_array_char *ret,
	532	GFC_INTEGER_4 ret_length __attribute__((unused)),
e6082041	533	const gfc_array_char vector, const gfc_array_l1 mask,
7823229b RS	534	char *field, GFC_INTEGER_4 vector_length,
	535	GFC_INTEGER_4 field_length __attribute__((unused)))
	536	{
	537	gfc_array_char tmp;
	538
c6e75626	539	memset (&tmp, 0, sizeof (tmp));
7823229b RS	540	tmp.dtype = 0;
	541	tmp.data = field;
	542	unpack_internal (ret, vector, mask, &tmp, vector_length, 0);
6de9cd9a	543	}
3571925e FXC	544
	545
	546	extern void unpack0_char4 (gfc_array_char *, GFC_INTEGER_4,
	547	const gfc_array_char , const gfc_array_l1 ,
	548	char *, GFC_INTEGER_4, GFC_INTEGER_4);
	549	export_proto(unpack0_char4);
	550
	551	void
	552	unpack0_char4 (gfc_array_char *ret,
	553	GFC_INTEGER_4 ret_length __attribute__((unused)),
	554	const gfc_array_char vector, const gfc_array_l1 mask,
	555	char *field, GFC_INTEGER_4 vector_length,
	556	GFC_INTEGER_4 field_length __attribute__((unused)))
	557	{
	558	gfc_array_char tmp;
	559
	560	memset (&tmp, 0, sizeof (tmp));
	561	tmp.dtype = 0;
	562	tmp.data = field;
	563	unpack_internal (ret, vector, mask, &tmp,
	564	vector_length * sizeof (gfc_char4_t), 0);
	565	}