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

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

#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);
}


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;
  index_type size;

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

  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));
}


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