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

/* Generic implementation of the UNPACK intrinsic
   Copyright 2002, 2003, 2004, 2005, 2007, 2009, 2010
   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 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>

/* All the bounds checking for unpack in one function.  If field is NULL,
   we don't check it, for the unpack0 functions.  */

static void
unpack_bounds (gfc_array_char *ret, const gfc_array_char *vector,
	 const gfc_array_l1 *mask, const gfc_array_char *field)
{
  index_type vec_size, mask_count;
  vec_size = size0 ((array_t *) vector);
  mask_count = count_0 (mask);
  if (vec_size < mask_count)
    runtime_error ("Incorrect size of return value in UNPACK"
		   " intrinsic: should be at least %ld, is"
		   " %ld", (long int) mask_count,
		   (long int) vec_size);

  if (field != NULL)
    bounds_equal_extents ((array_t *) field, (array_t *) mask,
			  "FIELD", "UNPACK");

  if (ret->data != NULL)
    bounds_equal_extents ((array_t *) ret, (array_t *) mask,
			  "return value", "UNPACK");

}

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)
{
  /* 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;
	  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_BYTES(ret, n);
	  fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
	  mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
	  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] = GFC_DESCRIPTOR_EXTENT(ret,n);
	  empty = empty || extent[n] <= 0;
	  rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret, n);
	  fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
	  mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
	}
    }

  if (empty)
    return;

  vstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
  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;

  if (unlikely(compile_options.bounds_check))
    unpack_bounds (ret, vector, mask, field);

  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;

/* FIXME: This here is a hack, which will have to be removed when
   the array descriptor is reworked.  Currently, we don't store the
   kind value for the type, but only the size.  Because on targets with
   __float128, we have sizeof(logn double) == sizeof(__float128),
   we cannot discriminate here and have to fall back to the generic
   handling (which is suboptimal).  */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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;

/* FIXME: This here is a hack, which will have to be removed when
   the array descriptor is reworked.  Currently, we don't store the
   kind value for the type, but only the size.  Because on targets with
   __float128, we have sizeof(logn double) == sizeof(__float128),
   we cannot discriminate here and have to fall back to the generic
   handling (which is suboptimal).  */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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);
}


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 __attribute__((unused)))
{

  if (unlikely(compile_options.bounds_check))
    unpack_bounds (ret, vector, mask, field);

  unpack_internal (ret, vector, mask, field, vector_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 __attribute__((unused)))
{

  if (unlikely(compile_options.bounds_check))
    unpack_bounds (ret, vector, mask, field);

  unpack_internal (ret, vector, mask, field,
		   vector_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;

  if (unlikely(compile_options.bounds_check))
    unpack_bounds (ret, vector, mask, NULL);

  type_size = GFC_DTYPE_TYPE_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;

/* FIXME: This here is a hack, which will have to be removed when
   the array descriptor is reworked.  Currently, we don't store the
   kind value for the type, but only the size.  Because on targets with
   __float128, we have sizeof(logn double) == sizeof(__float128),
   we cannot discriminate here and have to fall back to the generic
   handling (which is suboptimal).  */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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;

/* FIXME: This here is a hack, which will have to be removed when
   the array descriptor is reworked.  Currently, we don't store the
   kind value for the type, but only the size.  Because on targets with
   __float128, we have sizeof(logn double) == sizeof(__float128),
   we cannot discriminate here and have to fall back to the generic
   handling (which is suboptimal).  */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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));
}


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;

  if (unlikely(compile_options.bounds_check))
    unpack_bounds (ret, vector, mask, NULL);

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


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;

  if (unlikely(compile_options.bounds_check))
    unpack_bounds (ret, vector, mask, NULL);

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