void
unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
const gfc_array_l1 *mask, char *field)
{
gfc_array_char tmp;
index_type type_size;
index_type size;
type_size = GFC_DTYPE_TYPE_SIZE (vector);
size = GFC_DESCRIPTOR_SIZE (vector);
switch(type_size)
{
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_INTEGER_1:
case GFC_DTYPE_DERIVED_1:
unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
mask, (GFC_INTEGER_1 *) field);
return;
case GFC_DTYPE_LOGICAL_2:
case GFC_DTYPE_INTEGER_2:
unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
mask, (GFC_INTEGER_2 *) field);
return;
case GFC_DTYPE_LOGICAL_4:
case GFC_DTYPE_INTEGER_4:
unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
mask, (GFC_INTEGER_4 *) field);
return;
case GFC_DTYPE_LOGICAL_8:
case GFC_DTYPE_INTEGER_8:
unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
mask, (GFC_INTEGER_8 *) field);
return;
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_LOGICAL_16:
case GFC_DTYPE_INTEGER_16:
unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
mask, (GFC_INTEGER_16 *) field);
return;
#endif
case GFC_DTYPE_REAL_4:
unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
mask, (GFC_REAL_4 *) field);
return;
case GFC_DTYPE_REAL_8:
unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
mask, (GFC_REAL_8 *) field);
return;
#ifdef HAVE_GFC_REAL_10
case GFC_DTYPE_REAL_10:
unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
mask, (GFC_REAL_10 *) field);
return;
#endif
#ifdef HAVE_GFC_REAL_16
case GFC_DTYPE_REAL_16:
unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
mask, (GFC_REAL_16 *) field);
return;
#endif
case GFC_DTYPE_COMPLEX_4:
unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
mask, (GFC_COMPLEX_4 *) field);
return;
case GFC_DTYPE_COMPLEX_8:
unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
mask, (GFC_COMPLEX_8 *) field);
return;
#ifdef HAVE_GFC_COMPLEX_10
case GFC_DTYPE_COMPLEX_10:
unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
mask, (GFC_COMPLEX_10 *) field);
return;
#endif
#ifdef HAVE_GFC_COMPLEX_16
case GFC_DTYPE_COMPLEX_16:
unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
mask, (GFC_COMPLEX_16 *) field);
return;
#endif
case GFC_DTYPE_DERIVED_2:
if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
|| GFC_UNALIGNED_2(field))
break;
else
{
unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
mask, (GFC_INTEGER_2 *) field);
return;
}
case GFC_DTYPE_DERIVED_4:
if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
|| GFC_UNALIGNED_4(field))
break;
else
{
unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
mask, (GFC_INTEGER_4 *) field);
return;
}
case GFC_DTYPE_DERIVED_8:
if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
|| GFC_UNALIGNED_8(field))
break;
else
{
unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
mask, (GFC_INTEGER_8 *) field);
return;
}
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_DERIVED_16:
if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
|| GFC_UNALIGNED_16(field))
break;
else
{
unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
mask, (GFC_INTEGER_16 *) field);
return;
}
#endif
}
memset (&tmp, 0, sizeof (tmp));
tmp.dtype = 0;
tmp.data = field;
unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0);
}
static void
cshift0 (gfc_array_char * ret, const gfc_array_char * array,
ptrdiff_t shift, int which, index_type size)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type roffset;
char *rptr;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type soffset;
const char *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
index_type len;
index_type n;
index_type arraysize;
index_type type_size;
if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
arraysize = size0 ((array_t *) array);
if (ret->base_addr == NULL)
{
int i;
ret->offset = 0;
GFC_DTYPE_COPY(ret,array);
for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
{
index_type ub, str;
ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
if (i == 0)
str = 1;
else
str = GFC_DESCRIPTOR_EXTENT(ret,i-1) *
GFC_DESCRIPTOR_STRIDE(ret,i-1);
GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
}
/* xmallocarray allocates a single byte for zero size. */
ret->base_addr = xmallocarray (arraysize, size);
}
else if (unlikely (compile_options.bounds_check))
{
bounds_equal_extents ((array_t *) ret, (array_t *) array,
"return value", "CSHIFT");
}
if (arraysize == 0)
return;
type_size = GFC_DTYPE_TYPE_SIZE (array);
switch(type_size)
{
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_INTEGER_1:
cshift0_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array, shift, which);
return;
case GFC_DTYPE_LOGICAL_2:
case GFC_DTYPE_INTEGER_2:
cshift0_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array, shift, which);
return;
case GFC_DTYPE_LOGICAL_4:
case GFC_DTYPE_INTEGER_4:
cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift, which);
return;
case GFC_DTYPE_LOGICAL_8:
case GFC_DTYPE_INTEGER_8:
cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift, which);
return;
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_LOGICAL_16:
case GFC_DTYPE_INTEGER_16:
cshift0_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array, shift,
which);
return;
#endif
case GFC_DTYPE_REAL_4:
cshift0_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array, shift, which);
return;
case GFC_DTYPE_REAL_8:
cshift0_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array, shift, which);
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:
cshift0_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array, shift,
which);
return;
# endif
# ifdef HAVE_GFC_REAL_16
case GFC_DTYPE_REAL_16:
cshift0_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array, shift,
which);
return;
# endif
#endif
case GFC_DTYPE_COMPLEX_4:
cshift0_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array, shift, which);
return;
case GFC_DTYPE_COMPLEX_8:
cshift0_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array, shift, which);
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:
cshift0_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array, shift,
which);
return;
# endif
# ifdef HAVE_GFC_COMPLEX_16
case GFC_DTYPE_COMPLEX_16:
cshift0_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array, shift,
which);
return;
# endif
#endif
default:
break;
}
switch (size)
{
/* Let's check the actual alignment of the data pointers. If they
are suitably aligned, we can safely call the unpack functions. */
case sizeof (GFC_INTEGER_1):
cshift0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, shift,
which);
break;
case sizeof (GFC_INTEGER_2):
if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr))
break;
else
{
cshift0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, shift,
which);
return;
}
case sizeof (GFC_INTEGER_4):
if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr))
break;
else
{
cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift,
which);
return;
}
case sizeof (GFC_INTEGER_8):
if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr))
{
/* Let's try to use the complex routines. First, a sanity
check that the sizes match; this should be optimized to
a no-op. */
if (sizeof(GFC_INTEGER_8) != sizeof(GFC_COMPLEX_4))
break;
if (GFC_UNALIGNED_C4(ret->base_addr)
|| GFC_UNALIGNED_C4(array->base_addr))
break;
cshift0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, shift,
which);
return;
}
else
{
cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift,
which);
return;
}
#ifdef HAVE_GFC_INTEGER_16
case sizeof (GFC_INTEGER_16):
if (GFC_UNALIGNED_16(ret->base_addr)
|| GFC_UNALIGNED_16(array->base_addr))
{
/* Let's try to use the complex routines. First, a sanity
check that the sizes match; this should be optimized to
a no-op. */
if (sizeof(GFC_INTEGER_16) != sizeof(GFC_COMPLEX_8))
break;
if (GFC_UNALIGNED_C8(ret->base_addr)
|| GFC_UNALIGNED_C8(array->base_addr))
break;
cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
which);
return;
}
else
{
cshift0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
shift, which);
return;
}
#else
case sizeof (GFC_COMPLEX_8):
if (GFC_UNALIGNED_C8(ret->base_addr)
|| GFC_UNALIGNED_C8(array->base_addr))
break;
else
{
cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
which);
return;
}
#endif
default:
break;
}
which = which - 1;
sstride[0] = 0;
rstride[0] = 0;
extent[0] = 1;
count[0] = 0;
n = 0;
/* Initialized for avoiding compiler warnings. */
roffset = size;
soffset = size;
len = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
if (dim == which)
{
roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
if (roffset == 0)
roffset = size;
soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
if (soffset == 0)
soffset = size;
len = GFC_DESCRIPTOR_EXTENT(array,dim);
}
else
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
n++;
}
}
if (sstride[0] == 0)
sstride[0] = size;
if (rstride[0] == 0)
rstride[0] = size;
dim = GFC_DESCRIPTOR_RANK (array);
rstride0 = rstride[0];
sstride0 = sstride[0];
rptr = ret->base_addr;
sptr = array->base_addr;
shift = len == 0 ? 0 : shift % (ptrdiff_t)len;
if (shift < 0)
shift += len;
while (rptr)
{
/* Do the shift for this dimension. */
/* If elements are contiguous, perform the operation
in two block moves. */
if (soffset == size && roffset == size)
{
size_t len1 = shift * size;
size_t len2 = (len - shift) * size;
memcpy (rptr, sptr + len1, len2);
memcpy (rptr + len2, sptr, len1);
}
else
{
/* Otherwise, we'll have to perform the copy one element at
a time. */
char *dest = rptr;
const char *src = &sptr[shift * soffset];
for (n = 0; n < len - shift; n++)
{
memcpy (dest, src, size);
dest += roffset;
src += soffset;
}
for (src = sptr, n = 0; n < shift; n++)
{
memcpy (dest, src, size);
dest += roffset;
src += soffset;
}
}
/* Advance to the next section. */
rptr += rstride0;
sptr += sstride0;
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];
sptr -= sstride[n] * extent[n];
n++;
if (n >= dim - 1)
{
/* Break out of the loop. */
rptr = NULL;
break;
}
else
{
count[n]++;
rptr += rstride[n];
sptr += sstride[n];
}
}
}
}
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));
}
void
spread_scalar (gfc_array_char *ret, const char *source,
const index_type *along, const index_type *pncopies)
{
index_type type_size;
if (!ret->dtype)
runtime_error ("return array missing descriptor in spread()");
type_size = GFC_DTYPE_TYPE_SIZE(ret);
switch(type_size)
{
case GFC_DTYPE_DERIVED_1:
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_INTEGER_1:
spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_LOGICAL_2:
case GFC_DTYPE_INTEGER_2:
spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_LOGICAL_4:
case GFC_DTYPE_INTEGER_4:
spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_LOGICAL_8:
case GFC_DTYPE_INTEGER_8:
spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
*along, *pncopies);
return;
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_LOGICAL_16:
case GFC_DTYPE_INTEGER_16:
spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
*along, *pncopies);
return;
#endif
case GFC_DTYPE_REAL_4:
spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_REAL_8:
spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
*along, *pncopies);
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:
spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
*along, *pncopies);
return;
# endif
# ifdef HAVE_GFC_REAL_16
case GFC_DTYPE_REAL_16:
spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
*along, *pncopies);
return;
# endif
#endif
case GFC_DTYPE_COMPLEX_4:
spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_COMPLEX_8:
spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
*along, *pncopies);
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:
spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
*along, *pncopies);
return;
# endif
# ifdef HAVE_GFC_COMPLEX_16
case GFC_DTYPE_COMPLEX_16:
spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
*along, *pncopies);
return;
# endif
#endif
case GFC_DTYPE_DERIVED_2:
if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source))
break;
else
{
spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
*along, *pncopies);
return;
}
case GFC_DTYPE_DERIVED_4:
if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source))
break;
else
{
spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
*along, *pncopies);
return;
}
case GFC_DTYPE_DERIVED_8:
if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source))
break;
else
{
spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
*along, *pncopies);
return;
}
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_DERIVED_16:
if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(source))
break;
else
{
spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
*along, *pncopies);
return;
}
#endif
}
spread_internal_scalar (ret, source, along, pncopies);
}
void
pack (gfc_array_char *ret, const gfc_array_char *array,
const gfc_array_l1 *mask, const gfc_array_char *vector)
{
index_type type_size;
index_type size;
type_size = GFC_DTYPE_TYPE_SIZE(array);
switch(type_size)
{
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_INTEGER_1:
case GFC_DTYPE_DERIVED_1:
pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array,
(gfc_array_l1 *) mask, (gfc_array_i1 *) vector);
return;
case GFC_DTYPE_LOGICAL_2:
case GFC_DTYPE_INTEGER_2:
pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
(gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
return;
case GFC_DTYPE_LOGICAL_4:
case GFC_DTYPE_INTEGER_4:
pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
(gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
return;
case GFC_DTYPE_LOGICAL_8:
case GFC_DTYPE_INTEGER_8:
pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
(gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
return;
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_LOGICAL_16:
case GFC_DTYPE_INTEGER_16:
pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
(gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
return;
#endif
case GFC_DTYPE_REAL_4:
pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array,
(gfc_array_l1 *) mask, (gfc_array_r4 *) vector);
return;
case GFC_DTYPE_REAL_8:
pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array,
(gfc_array_l1 *) mask, (gfc_array_r8 *) vector);
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:
pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array,
(gfc_array_l1 *) mask, (gfc_array_r10 *) vector);
return;
# endif
# ifdef HAVE_GFC_REAL_16
case GFC_DTYPE_REAL_16:
pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array,
(gfc_array_l1 *) mask, (gfc_array_r16 *) vector);
return;
# endif
#endif
case GFC_DTYPE_COMPLEX_4:
pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array,
(gfc_array_l1 *) mask, (gfc_array_c4 *) vector);
return;
case GFC_DTYPE_COMPLEX_8:
pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array,
(gfc_array_l1 *) mask, (gfc_array_c8 *) vector);
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:
pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array,
(gfc_array_l1 *) mask, (gfc_array_c10 *) vector);
return;
# endif
# ifdef HAVE_GFC_COMPLEX_16
case GFC_DTYPE_COMPLEX_16:
pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array,
(gfc_array_l1 *) mask, (gfc_array_c16 *) vector);
return;
# endif
#endif
/* For derived types, let's check the actual alignment of the
data pointers. If they are aligned, we can safely call
the unpack functions. */
case GFC_DTYPE_DERIVED_2:
if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr)
|| (vector && GFC_UNALIGNED_2(vector->base_addr)))
break;
else
{
pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
(gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
return;
}
case GFC_DTYPE_DERIVED_4:
if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr)
|| (vector && GFC_UNALIGNED_4(vector->base_addr)))
break;
else
{
pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
(gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
return;
}
case GFC_DTYPE_DERIVED_8:
if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr)
|| (vector && GFC_UNALIGNED_8(vector->base_addr)))
break;
else
{
pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
(gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
return;
}
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_DERIVED_16:
if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(array->base_addr)
|| (vector && GFC_UNALIGNED_16(vector->base_addr)))
break;
else
{
pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
(gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
return;
}
#endif
}
size = GFC_DESCRIPTOR_SIZE (array);
pack_internal (ret, array, mask, vector, size);
}
void *
internal_pack (gfc_array_char * source)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type stride[GFC_MAX_DIMENSIONS];
index_type stride0;
index_type dim;
index_type ssize;
const char *src;
char *dest;
void *destptr;
int n;
int packed;
index_type size;
index_type type_size;
if (source->base_addr == NULL)
return NULL;
type_size = GFC_DTYPE_TYPE_SIZE(source);
size = GFC_DESCRIPTOR_SIZE (source);
switch (type_size)
{
case GFC_DTYPE_INTEGER_1:
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_DERIVED_1:
return internal_pack_1 ((gfc_array_i1 *) source);
case GFC_DTYPE_INTEGER_2:
case GFC_DTYPE_LOGICAL_2:
return internal_pack_2 ((gfc_array_i2 *) source);
case GFC_DTYPE_INTEGER_4:
case GFC_DTYPE_LOGICAL_4:
return internal_pack_4 ((gfc_array_i4 *) source);
case GFC_DTYPE_INTEGER_8:
case GFC_DTYPE_LOGICAL_8:
return internal_pack_8 ((gfc_array_i8 *) source);
#if defined(HAVE_GFC_INTEGER_16)
case GFC_DTYPE_INTEGER_16:
case GFC_DTYPE_LOGICAL_16:
return internal_pack_16 ((gfc_array_i16 *) source);
#endif
case GFC_DTYPE_REAL_4:
return internal_pack_r4 ((gfc_array_r4 *) source);
case GFC_DTYPE_REAL_8:
return internal_pack_r8 ((gfc_array_r8 *) source);
/* 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)
# if defined (HAVE_GFC_REAL_10)
case GFC_DTYPE_REAL_10:
return internal_pack_r10 ((gfc_array_r10 *) source);
# endif
# if defined (HAVE_GFC_REAL_16)
case GFC_DTYPE_REAL_16:
return internal_pack_r16 ((gfc_array_r16 *) source);
# endif
#endif
case GFC_DTYPE_COMPLEX_4:
return internal_pack_c4 ((gfc_array_c4 *) source);
case GFC_DTYPE_COMPLEX_8:
return internal_pack_c8 ((gfc_array_c8 *) source);
/* 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)
# if defined (HAVE_GFC_COMPLEX_10)
case GFC_DTYPE_COMPLEX_10:
return internal_pack_c10 ((gfc_array_c10 *) source);
# endif
# if defined (HAVE_GFC_COMPLEX_16)
case GFC_DTYPE_COMPLEX_16:
return internal_pack_c16 ((gfc_array_c16 *) source);
# endif
#endif
case GFC_DTYPE_DERIVED_2:
if (GFC_UNALIGNED_2(source->base_addr))
break;
else
return internal_pack_2 ((gfc_array_i2 *) source);
case GFC_DTYPE_DERIVED_4:
if (GFC_UNALIGNED_4(source->base_addr))
break;
else
return internal_pack_4 ((gfc_array_i4 *) source);
case GFC_DTYPE_DERIVED_8:
if (GFC_UNALIGNED_8(source->base_addr))
break;
else
return internal_pack_8 ((gfc_array_i8 *) source);
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_DERIVED_16:
if (GFC_UNALIGNED_16(source->base_addr))
break;
else
return internal_pack_16 ((gfc_array_i16 *) source);
#endif
default:
break;
}
dim = GFC_DESCRIPTOR_RANK (source);
ssize = 1;
packed = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
stride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
if (extent[n] <= 0)
{
/* Do nothing. */
packed = 1;
break;
}
if (ssize != stride[n])
packed = 0;
ssize *= extent[n];
}
if (packed)
return source->base_addr;
/* Allocate storage for the destination. */
destptr = xmallocarray (ssize, size);
dest = (char *)destptr;
src = source->base_addr;
stride0 = stride[0] * size;
while (src)
{
/* Copy the data. */
memcpy(dest, src, size);
/* Advance to the next element. */
dest += size;
src += stride0;
count[0]++;
/* Advance to the next source element. */
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. */
src -= stride[n] * extent[n] * size;
n++;
if (n == dim)
{
src = NULL;
break;
}
else
{
count[n]++;
src += stride[n] * size;
}
}
}
return destptr;
}
void
internal_unpack (gfc_array_char * d, const void * s)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type stride[GFC_MAX_DIMENSIONS];
index_type stride0;
index_type dim;
index_type dsize;
char *dest;
const char *src;
int n;
int size;
int type_size;
dest = d->base_addr;
/* This check may be redundant, but do it anyway. */
if (s == dest || !s)
return;
type_size = GFC_DTYPE_TYPE_SIZE (d);
switch (type_size)
{
case GFC_DTYPE_INTEGER_1:
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_DERIVED_1:
internal_unpack_1 ((gfc_array_i1 *) d, (const GFC_INTEGER_1 *) s);
return;
case GFC_DTYPE_INTEGER_2:
case GFC_DTYPE_LOGICAL_2:
internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s);
return;
case GFC_DTYPE_INTEGER_4:
case GFC_DTYPE_LOGICAL_4:
internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s);
return;
case GFC_DTYPE_INTEGER_8:
case GFC_DTYPE_LOGICAL_8:
internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s);
return;
#if defined (HAVE_GFC_INTEGER_16)
case GFC_DTYPE_INTEGER_16:
case GFC_DTYPE_LOGICAL_16:
internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s);
return;
#endif
case GFC_DTYPE_REAL_4:
internal_unpack_r4 ((gfc_array_r4 *) d, (const GFC_REAL_4 *) s);
return;
case GFC_DTYPE_REAL_8:
internal_unpack_r8 ((gfc_array_r8 *) d, (const GFC_REAL_8 *) s);
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)
# if defined(HAVE_GFC_REAL_10)
case GFC_DTYPE_REAL_10:
internal_unpack_r10 ((gfc_array_r10 *) d, (const GFC_REAL_10 *) s);
return;
# endif
# if defined(HAVE_GFC_REAL_16)
case GFC_DTYPE_REAL_16:
internal_unpack_r16 ((gfc_array_r16 *) d, (const GFC_REAL_16 *) s);
return;
# endif
#endif
case GFC_DTYPE_COMPLEX_4:
internal_unpack_c4 ((gfc_array_c4 *)d, (const GFC_COMPLEX_4 *)s);
return;
case GFC_DTYPE_COMPLEX_8:
internal_unpack_c8 ((gfc_array_c8 *)d, (const GFC_COMPLEX_8 *)s);
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)
# if defined(HAVE_GFC_COMPLEX_10)
case GFC_DTYPE_COMPLEX_10:
internal_unpack_c10 ((gfc_array_c10 *) d, (const GFC_COMPLEX_10 *) s);
return;
# endif
# if defined(HAVE_GFC_COMPLEX_16)
case GFC_DTYPE_COMPLEX_16:
internal_unpack_c16 ((gfc_array_c16 *) d, (const GFC_COMPLEX_16 *) s);
return;
# endif
#endif
case GFC_DTYPE_DERIVED_2:
if (GFC_UNALIGNED_2(d->base_addr) || GFC_UNALIGNED_2(s))
break;
else
{
internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s);
return;
}
case GFC_DTYPE_DERIVED_4:
if (GFC_UNALIGNED_4(d->base_addr) || GFC_UNALIGNED_4(s))
break;
else
{
internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s);
return;
}
case GFC_DTYPE_DERIVED_8:
if (GFC_UNALIGNED_8(d->base_addr) || GFC_UNALIGNED_8(s))
break;
else
{
internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s);
return;
}
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_DERIVED_16:
if (GFC_UNALIGNED_16(d->base_addr) || GFC_UNALIGNED_16(s))
break;
else
{
internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s);
return;
}
#endif
default:
break;
}
size = GFC_DESCRIPTOR_SIZE (d);
dim = GFC_DESCRIPTOR_RANK (d);
dsize = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
stride[n] = GFC_DESCRIPTOR_STRIDE(d,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(d,n);
if (extent[n] <= 0)
return;
if (dsize == stride[n])
dsize *= extent[n];
else
dsize = 0;
}
src = s;
if (dsize != 0)
{
memcpy (dest, src, dsize * size);
return;
}
stride0 = stride[0] * size;
while (dest)
{
/* Copy the data. */
memcpy (dest, src, size);
/* Advance to the next element. */
src += size;
dest += stride0;
count[0]++;
/* Advance to the next source element. */
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. */
dest -= stride[n] * extent[n] * size;
n++;
if (n == dim)
{
dest = NULL;
break;
}
else
{
count[n]++;
dest += stride[n] * size;
}
}
}
}
void
spread_scalar (gfc_array_char *ret, const char *source,
const index_type *along, const index_type *pncopies)
{
index_type type_size;
if (!ret->dtype)
runtime_error ("return array missing descriptor in spread()");
type_size = GFC_DTYPE_TYPE_SIZE(ret);
switch(type_size)
{
case GFC_DTYPE_DERIVED_1:
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_INTEGER_1:
spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_LOGICAL_2:
case GFC_DTYPE_INTEGER_2:
spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_LOGICAL_4:
case GFC_DTYPE_INTEGER_4:
spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_LOGICAL_8:
case GFC_DTYPE_INTEGER_8:
spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
*along, *pncopies);
return;
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_LOGICAL_16:
case GFC_DTYPE_INTEGER_16:
spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
*along, *pncopies);
return;
#endif
case GFC_DTYPE_REAL_4:
spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_REAL_8:
spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
*along, *pncopies);
return;
#ifdef HAVE_GFC_REAL_10
case GFC_DTYPE_REAL_10:
spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
*along, *pncopies);
return;
#endif
#ifdef HAVE_GFC_REAL_16
case GFC_DTYPE_REAL_16:
spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
*along, *pncopies);
return;
#endif
case GFC_DTYPE_COMPLEX_4:
spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_COMPLEX_8:
spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
*along, *pncopies);
return;
#ifdef HAVE_GFC_COMPLEX_10
case GFC_DTYPE_COMPLEX_10:
spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
*along, *pncopies);
return;
#endif
#ifdef HAVE_GFC_COMPLEX_16
case GFC_DTYPE_COMPLEX_16:
spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
*along, *pncopies);
return;
#endif
case GFC_DTYPE_DERIVED_2:
if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(source))
break;
else
{
spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
*along, *pncopies);
return;
}
case GFC_DTYPE_DERIVED_4:
if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(source))
break;
else
{
spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
*along, *pncopies);
return;
}
case GFC_DTYPE_DERIVED_8:
if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(source))
break;
else
{
spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
*along, *pncopies);
return;
}
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_DERIVED_16:
if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(source))
break;
else
{
spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
*along, *pncopies);
return;
}
#endif
}
spread_internal_scalar (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (ret));
}
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);
}