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

/* Generic implementation of the UNPACK intrinsic
   Copyright 2002, 2003, 2004, 2005, 2007, 2009, 2010, 2012
   Free Software Foundation, Inc.
   Contributed 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>

/* 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->base_addr != 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->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
      )
    {
      /*  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->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_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->base_addr = 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->base_addr;
  fptr = field->base_addr;
  vptr = vector->base_addr;

  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->base_addr) || GFC_UNALIGNED_2(vector->base_addr)
	  || GFC_UNALIGNED_2(field->base_addr))
	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->base_addr) || GFC_UNALIGNED_4(vector->base_addr)
	  || GFC_UNALIGNED_4(field->base_addr))
	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->base_addr) || GFC_UNALIGNED_8(vector->base_addr)
	  || GFC_UNALIGNED_8(field->base_addr))
	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->base_addr)
	  || GFC_UNALIGNED_16(vector->base_addr)
	  || GFC_UNALIGNED_16(field->base_addr))
	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->base_addr) || GFC_UNALIGNED_2(vector->base_addr)
	  || 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->base_addr) || GFC_UNALIGNED_4(vector->base_addr)
	  || 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->base_addr) || GFC_UNALIGNED_8(vector->base_addr)
	  || 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->base_addr)
	  || GFC_UNALIGNED_16(vector->base_addr)
	  || 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.base_addr = 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.base_addr = 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.base_addr = field;
  unpack_internal (ret, vector, mask, &tmp,
		   vector_length * sizeof (gfc_char4_t));
}
Commit	Line	Data
ba4a3d54	1	/* Generic implementation of the UNPACK intrinsic
21d1335b	2	Copyright 2002, 2003, 2004, 2005, 2007, 2009, 2010, 2012
d652f226	3	Free Software Foundation, Inc.
6de9cd9a DN	4	Contributed by Paul Brook <paul@nowt.org>
6de9cd9a DN	5
21d1335b	6	This file is part of the GNU Fortran 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
21d1335b	52	if (ret->base_addr != NULL)
8c39b987 TK	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	89
21d1335b	90	mptr = mask->base_addr;
28dc6b33 TK	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
21d1335b	110	if (ret->base_addr == 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;
21d1335b	129	ret->base_addr = internal_malloc_size (rs * size);
ba4a3d54 TK	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];
21d1335b TB	152	rptr = ret->base_addr;
	153	fptr = field->base_addr;
	154	vptr = vector->base_addr;
6de9cd9a	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
c7d0f4d5 TK	319	case GFC_DTYPE_DERIVED_2:
21d1335b TB	320	if (GFC_UNALIGNED_2(ret->base_addr) \|\| GFC_UNALIGNED_2(vector->base_addr)
21d1335b TB	321	\|\| GFC_UNALIGNED_2(field->base_addr))
c7d0f4d5 TK	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:
21d1335b TB	331	if (GFC_UNALIGNED_4(ret->base_addr) \|\| GFC_UNALIGNED_4(vector->base_addr)
21d1335b TB	332	\|\| GFC_UNALIGNED_4(field->base_addr))
c7d0f4d5 TK	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:
21d1335b TB	342	if (GFC_UNALIGNED_8(ret->base_addr) \|\| GFC_UNALIGNED_8(vector->base_addr)
21d1335b TB	343	\|\| GFC_UNALIGNED_8(field->base_addr))
c7d0f4d5 TK	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
c7d0f4d5 TK	353	case GFC_DTYPE_DERIVED_16:
21d1335b TB	354	if (GFC_UNALIGNED_16(ret->base_addr)
	355	\|\| GFC_UNALIGNED_16(vector->base_addr)
	356	\|\| GFC_UNALIGNED_16(field->base_addr))
c7d0f4d5 TK	357	break;
	358	else
	359	{
	360	unpack1_i16 ((gfc_array_i16 ) ret, (gfc_array_i16 ) vector,
	361	mask, (gfc_array_i16 *) field);
	362	return;
	363	}
	364	#endif
3478bba4	365	}
c7d0f4d5	366
23db9913	367	unpack_internal (ret, vector, mask, field, size);
7823229b RS	368	}
7823229b RS	369
3571925e	370
7823229b	371	extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
e6082041	372	const gfc_array_char , const gfc_array_l1 ,
7823229b RS	373	const gfc_array_char *, GFC_INTEGER_4,
	374	GFC_INTEGER_4);
	375	export_proto(unpack1_char);
	376
	377	void
	378	unpack1_char (gfc_array_char *ret,
	379	GFC_INTEGER_4 ret_length __attribute__((unused)),
e6082041	380	const gfc_array_char vector, const gfc_array_l1 mask,
7823229b	381	const gfc_array_char *field, GFC_INTEGER_4 vector_length,
23db9913	382	GFC_INTEGER_4 field_length __attribute__((unused)))
7823229b	383	{
8c39b987 TK	384
	385	if (unlikely(compile_options.bounds_check))
	386	unpack_bounds (ret, vector, mask, field);
	387
23db9913	388	unpack_internal (ret, vector, mask, field, vector_length);
7823229b	389	}
6de9cd9a	390
3571925e FXC	391
	392	extern void unpack1_char4 (gfc_array_char *, GFC_INTEGER_4,
	393	const gfc_array_char , const gfc_array_l1 ,
	394	const gfc_array_char *, GFC_INTEGER_4,
	395	GFC_INTEGER_4);
	396	export_proto(unpack1_char4);
	397
	398	void
	399	unpack1_char4 (gfc_array_char *ret,
	400	GFC_INTEGER_4 ret_length __attribute__((unused)),
	401	const gfc_array_char vector, const gfc_array_l1 mask,
	402	const gfc_array_char *field, GFC_INTEGER_4 vector_length,
23db9913	403	GFC_INTEGER_4 field_length __attribute__((unused)))
3571925e	404	{
8c39b987 TK	405
	406	if (unlikely(compile_options.bounds_check))
	407	unpack_bounds (ret, vector, mask, field);
	408
3571925e	409	unpack_internal (ret, vector, mask, field,
23db9913	410	vector_length * sizeof (gfc_char4_t));
3571925e FXC	411	}
	412
	413
a3b6aba2	414	extern void unpack0 (gfc_array_char , const gfc_array_char ,
e6082041	415	const gfc_array_l1 , char );
7f68c75f	416	export_proto(unpack0);
7d7b8bfe	417
6de9cd9a	418	void
a3b6aba2	419	unpack0 (gfc_array_char ret, const gfc_array_char vector,
e6082041	420	const gfc_array_l1 mask, char field)
6de9cd9a DN	421	{
	422	gfc_array_char tmp;
	423
c7d0f4d5	424	index_type type_size;
3478bba4	425
8c39b987 TK	426	if (unlikely(compile_options.bounds_check))
	427	unpack_bounds (ret, vector, mask, NULL);
	428
c7d0f4d5	429	type_size = GFC_DTYPE_TYPE_SIZE (vector);
3478bba4	430
14ca4cf8	431	switch (type_size)
3478bba4	432	{
c7d0f4d5 TK	433	case GFC_DTYPE_LOGICAL_1:
	434	case GFC_DTYPE_INTEGER_1:
	435	case GFC_DTYPE_DERIVED_1:
	436	unpack0_i1 ((gfc_array_i1 ) ret, (gfc_array_i1 ) vector,
	437	mask, (GFC_INTEGER_1 *) field);
	438	return;
	439
	440	case GFC_DTYPE_LOGICAL_2:
	441	case GFC_DTYPE_INTEGER_2:
	442	unpack0_i2 ((gfc_array_i2 ) ret, (gfc_array_i2 ) vector,
	443	mask, (GFC_INTEGER_2 *) field);
	444	return;
	445
	446	case GFC_DTYPE_LOGICAL_4:
	447	case GFC_DTYPE_INTEGER_4:
	448	unpack0_i4 ((gfc_array_i4 ) ret, (gfc_array_i4 ) vector,
	449	mask, (GFC_INTEGER_4 *) field);
	450	return;
	451
	452	case GFC_DTYPE_LOGICAL_8:
	453	case GFC_DTYPE_INTEGER_8:
	454	unpack0_i8 ((gfc_array_i8 ) ret, (gfc_array_i8 ) vector,
	455	mask, (GFC_INTEGER_8 *) field);
	456	return;
3478bba4 TK	457
3478bba4 TK	458	#ifdef HAVE_GFC_INTEGER_16
c7d0f4d5 TK	459	case GFC_DTYPE_LOGICAL_16:
	460	case GFC_DTYPE_INTEGER_16:
	461	unpack0_i16 ((gfc_array_i16 ) ret, (gfc_array_i16 ) vector,
	462	mask, (GFC_INTEGER_16 *) field);
	463	return;
3478bba4	464	#endif
075abad5	465
c7d0f4d5 TK	466	case GFC_DTYPE_REAL_4:
	467	unpack0_r4 ((gfc_array_r4 ) ret, (gfc_array_r4 ) vector,
	468	mask, (GFC_REAL_4 *) field);
	469	return;
3478bba4	470
c7d0f4d5 TK	471	case GFC_DTYPE_REAL_8:
	472	unpack0_r8 ((gfc_array_r8 ) ret, (gfc_array_r8) vector,
	473	mask, (GFC_REAL_8 *) field);
	474	return;
3478bba4	475
1ec601bf FXC	476	/* FIXME: This here is a hack, which will have to be removed when
	477	the array descriptor is reworked. Currently, we don't store the
	478	kind value for the type, but only the size. Because on targets with
	479	__float128, we have sizeof(logn double) == sizeof(__float128),
	480	we cannot discriminate here and have to fall back to the generic
	481	handling (which is suboptimal). */
	482	#if !defined(GFC_REAL_16_IS_FLOAT128)
	483	# ifdef HAVE_GFC_REAL_10
c7d0f4d5 TK	484	case GFC_DTYPE_REAL_10:
	485	unpack0_r10 ((gfc_array_r10 ) ret, (gfc_array_r10 ) vector,
	486	mask, (GFC_REAL_10 *) field);
	487	return;
1ec601bf	488	# endif
3478bba4	489
1ec601bf	490	# ifdef HAVE_GFC_REAL_16
c7d0f4d5 TK	491	case GFC_DTYPE_REAL_16:
	492	unpack0_r16 ((gfc_array_r16 ) ret, (gfc_array_r16 ) vector,
	493	mask, (GFC_REAL_16 *) field);
	494	return;
1ec601bf	495	# endif
3478bba4	496	#endif
3478bba4	497
c7d0f4d5 TK	498	case GFC_DTYPE_COMPLEX_4:
	499	unpack0_c4 ((gfc_array_c4 ) ret, (gfc_array_c4 ) vector,
	500	mask, (GFC_COMPLEX_4 *) field);
	501	return;
3478bba4	502
c7d0f4d5 TK	503	case GFC_DTYPE_COMPLEX_8:
	504	unpack0_c8 ((gfc_array_c8 ) ret, (gfc_array_c8 ) vector,
	505	mask, (GFC_COMPLEX_8 *) field);
	506	return;
3478bba4	507
1ec601bf FXC	508	/* FIXME: This here is a hack, which will have to be removed when
	509	the array descriptor is reworked. Currently, we don't store the
	510	kind value for the type, but only the size. Because on targets with
	511	__float128, we have sizeof(logn double) == sizeof(__float128),
	512	we cannot discriminate here and have to fall back to the generic
	513	handling (which is suboptimal). */
	514	#if !defined(GFC_REAL_16_IS_FLOAT128)
	515	# ifdef HAVE_GFC_COMPLEX_10
c7d0f4d5 TK	516	case GFC_DTYPE_COMPLEX_10:
	517	unpack0_c10 ((gfc_array_c10 ) ret, (gfc_array_c10 ) vector,
	518	mask, (GFC_COMPLEX_10 *) field);
	519	return;
1ec601bf	520	# endif
3478bba4	521
1ec601bf	522	# ifdef HAVE_GFC_COMPLEX_16
c7d0f4d5 TK	523	case GFC_DTYPE_COMPLEX_16:
	524	unpack0_c16 ((gfc_array_c16 ) ret, (gfc_array_c16 ) vector,
	525	mask, (GFC_COMPLEX_16 *) field);
	526	return;
1ec601bf	527	# endif
3478bba4	528	#endif
075abad5	529
c7d0f4d5	530	case GFC_DTYPE_DERIVED_2:
21d1335b	531	if (GFC_UNALIGNED_2(ret->base_addr) \|\| GFC_UNALIGNED_2(vector->base_addr)
c7d0f4d5 TK	532	\|\| GFC_UNALIGNED_2(field))
	533	break;
	534	else
	535	{
	536	unpack0_i2 ((gfc_array_i2 ) ret, (gfc_array_i2 ) vector,
	537	mask, (GFC_INTEGER_2 *) field);
	538	return;
	539	}
	540
	541	case GFC_DTYPE_DERIVED_4:
21d1335b	542	if (GFC_UNALIGNED_4(ret->base_addr) \|\| GFC_UNALIGNED_4(vector->base_addr)
c7d0f4d5 TK	543	\|\| GFC_UNALIGNED_4(field))
	544	break;
	545	else
	546	{
	547	unpack0_i4 ((gfc_array_i4 ) ret, (gfc_array_i4 ) vector,
	548	mask, (GFC_INTEGER_4 *) field);
	549	return;
	550	}
	551
	552	case GFC_DTYPE_DERIVED_8:
21d1335b	553	if (GFC_UNALIGNED_8(ret->base_addr) \|\| GFC_UNALIGNED_8(vector->base_addr)
c7d0f4d5 TK	554	\|\| GFC_UNALIGNED_8(field))
	555	break;
	556	else
	557	{
	558	unpack0_i8 ((gfc_array_i8 ) ret, (gfc_array_i8 ) vector,
	559	mask, (GFC_INTEGER_8 *) field);
	560	return;
	561	}
075abad5	562
c7d0f4d5 TK	563	#ifdef HAVE_GFC_INTEGER_16
c7d0f4d5 TK	564	case GFC_DTYPE_DERIVED_16:
21d1335b TB	565	if (GFC_UNALIGNED_16(ret->base_addr)
21d1335b TB	566	\|\| GFC_UNALIGNED_16(vector->base_addr)
c7d0f4d5 TK	567	\|\| GFC_UNALIGNED_16(field))
	568	break;
	569	else
	570	{
	571	unpack0_i16 ((gfc_array_i16 ) ret, (gfc_array_i16 ) vector,
	572	mask, (GFC_INTEGER_16 *) field);
	573	return;
3478bba4	574	}
c7d0f4d5	575	#endif
075abad5	576
3478bba4	577	}
c7d0f4d5	578
c6e75626	579	memset (&tmp, 0, sizeof (tmp));
6de9cd9a	580	tmp.dtype = 0;
21d1335b	581	tmp.base_addr = field;
23db9913	582	unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector));
7823229b RS	583	}
7823229b RS	584
3571925e	585
7823229b	586	extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
e6082041	587	const gfc_array_char , const gfc_array_l1 ,
7823229b RS	588	char *, GFC_INTEGER_4, GFC_INTEGER_4);
	589	export_proto(unpack0_char);
	590
	591	void
	592	unpack0_char (gfc_array_char *ret,
	593	GFC_INTEGER_4 ret_length __attribute__((unused)),
e6082041	594	const gfc_array_char vector, const gfc_array_l1 mask,
7823229b RS	595	char *field, GFC_INTEGER_4 vector_length,
	596	GFC_INTEGER_4 field_length __attribute__((unused)))
	597	{
	598	gfc_array_char tmp;
	599
8c39b987 TK	600	if (unlikely(compile_options.bounds_check))
	601	unpack_bounds (ret, vector, mask, NULL);
	602
c6e75626	603	memset (&tmp, 0, sizeof (tmp));
7823229b	604	tmp.dtype = 0;
21d1335b	605	tmp.base_addr = field;
23db9913	606	unpack_internal (ret, vector, mask, &tmp, vector_length);
6de9cd9a	607	}
3571925e FXC	608
	609
	610	extern void unpack0_char4 (gfc_array_char *, GFC_INTEGER_4,
	611	const gfc_array_char , const gfc_array_l1 ,
	612	char *, GFC_INTEGER_4, GFC_INTEGER_4);
	613	export_proto(unpack0_char4);
	614
	615	void
	616	unpack0_char4 (gfc_array_char *ret,
	617	GFC_INTEGER_4 ret_length __attribute__((unused)),
	618	const gfc_array_char vector, const gfc_array_l1 mask,
	619	char *field, GFC_INTEGER_4 vector_length,
	620	GFC_INTEGER_4 field_length __attribute__((unused)))
	621	{
	622	gfc_array_char tmp;
	623
8c39b987 TK	624	if (unlikely(compile_options.bounds_check))
	625	unpack_bounds (ret, vector, mask, NULL);
	626
3571925e FXC	627	memset (&tmp, 0, sizeof (tmp));
3571925e FXC	628	tmp.dtype = 0;
21d1335b	629	tmp.base_addr = field;
3571925e	630	unpack_internal (ret, vector, mask, &tmp,
23db9913	631	vector_length * sizeof (gfc_char4_t));
3571925e	632	}