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");
}
void
pack_i1 (gfc_array_i1 *ret, const gfc_array_i1 *array,
const gfc_array_l1 *mask, const gfc_array_i1 *vector)
{
/* r.* indicates the return array. */
index_type rstride0;
GFC_INTEGER_1 * restrict rptr;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
const GFC_INTEGER_1 *sptr;
/* 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];
int zero_sized;
index_type n;
index_type dim;
index_type nelem;
index_type total;
int mask_kind;
dim = GFC_DESCRIPTOR_RANK (array);
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
)
{
/* Do not 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");
zero_sized = 0;
for (n = 0; n < dim; n++)
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] <= 0)
zero_sized = 1;
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
}
if (sstride[0] == 0)
sstride[0] = 1;
if (mstride[0] == 0)
mstride[0] = mask_kind;
if (zero_sized)
sptr = NULL;
else
sptr = array->base_addr;
if (ret->base_addr == NULL || unlikely (compile_options.bounds_check))
{
/* Count the elements, either for allocating memory or
for bounds checking. */
if (vector != NULL)
{
/* The return array will have as many
elements as there are in VECTOR. */
total = GFC_DESCRIPTOR_EXTENT(vector,0);
if (total < 0)
{
total = 0;
vector = NULL;
}
}
else
{
/* We have to count the true elements in MASK. */
total = count_0 (mask);
}
if (ret->base_addr == NULL)
{
/* Setup the array descriptor. */
GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);
ret->offset = 0;
/* xmalloc allocates a single byte for zero size. */
ret->base_addr = xmalloc (sizeof (GFC_INTEGER_1) * total);
if (total == 0)
return;
}
else
{
/* We come here because of range checking. */
index_type ret_extent;
ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
if (total != ret_extent)
runtime_error ("Incorrect extent in return value of PACK intrinsic;"
" is %ld, should be %ld", (long int) total,
(long int) ret_extent);
}
}
rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0);
if (rstride0 == 0)
rstride0 = 1;
sstride0 = sstride[0];
mstride0 = mstride[0];
rptr = ret->base_addr;
while (sptr && mptr)
{
/* Test this element. */
if (*mptr)
{
/* Add it. */
*rptr = *sptr;
rptr += rstride0;
}
/* Advance to the next element. */
sptr += sstride0;
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. */
sptr -= sstride[n] * extent[n];
mptr -= mstride[n] * extent[n];
n++;
if (n >= dim)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
mptr += mstride[n];
}
}
}
/* Add any remaining elements from VECTOR. */
if (vector)
{
n = GFC_DESCRIPTOR_EXTENT(vector,0);
nelem = ((rptr - ret->base_addr) / rstride0);
if (n > nelem)
{
sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
if (sstride0 == 0)
sstride0 = 1;
sptr = vector->base_addr + sstride0 * nelem;
n -= nelem;
while (n--)
{
*rptr = *sptr;
rptr += rstride0;
sptr += sstride0;
}
}
}
}