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
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;
}
}
}
}
static void
spread_internal (gfc_array_char *ret, const gfc_array_char *source,
const index_type *along, const index_type *pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
char *rptr;
char *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const char *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
index_type size;
size = GFC_DESCRIPTOR_SIZE(source);
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (*along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = *pncopies;
if (ret->base_addr == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
size_t ub, stride;
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
stride = rs;
if (n == *along - 1)
{
ub = ncopies - 1;
rdelta = rs * size;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
rstride[dim] = rs * size;
ub = extent[dim]-1;
rs *= extent[dim];
dim++;
}
GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
}
ret->offset = 0;
ret->base_addr = xmallocarray (rs, size);
if (rs <= 0)
return;
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
if (n == *along - 1)
{
rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == *along - 1)
{
rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
}
else
{
count[dim] = 0;
extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = size;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->base_addr;
sptr = source->base_addr;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
memcpy (dest, sptr, size);
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
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, index_type fsize)
{
/* 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 (rstride[0] == 0)
rstride[0] = size;
}
if (empty)
return;
if (fstride[0] == 0)
fstride[0] = fsize;
if (mstride[0] == 0)
mstride[0] = 1;
vstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
if (vstride0 == 0)
vstride0 = size;
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];
}
}
}
}
void
ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void *c_ptr_in,
gfc_array_void *f_ptr_out,
const array_t *shape)
{
int i = 0;
int shapeSize = 0;
GFC_DESCRIPTOR_DATA (f_ptr_out) = c_ptr_in;
if (shape != NULL)
{
index_type source_stride, size;
index_type str = 1;
char *p;
f_ptr_out->offset = str;
shapeSize = 0;
p = shape->base_addr;
size = GFC_DESCRIPTOR_SIZE(shape);
source_stride = GFC_DESCRIPTOR_STRIDE_BYTES(shape,0);
/* shape's length (rank of the output array) */
shapeSize = GFC_DESCRIPTOR_EXTENT(shape,0);
for (i = 0; i < shapeSize; i++)
{
index_type ub;
/* Have to allow for the SHAPE array to be any valid kind for
an INTEGER type. */
switch (size)
{
#ifdef HAVE_GFC_INTEGER_1
case 1:
ub = *((GFC_INTEGER_1 *) p);
break;
#endif
#ifdef HAVE_GFC_INTEGER_2
case 2:
ub = *((GFC_INTEGER_2 *) p);
break;
#endif
#ifdef HAVE_GFC_INTEGER_4
case 4:
ub = *((GFC_INTEGER_4 *) p);
break;
#endif
#ifdef HAVE_GFC_INTEGER_8
case 8:
ub = *((GFC_INTEGER_8 *) p);
break;
#endif
#ifdef HAVE_GFC_INTEGER_16
case 16:
ub = *((GFC_INTEGER_16 *) p);
break;
#endif
default:
internal_error (NULL, "c_f_pointer_u0: Invalid size");
}
p += source_stride;
if (i != 0)
{
str = str * GFC_DESCRIPTOR_EXTENT(f_ptr_out,i-1);
f_ptr_out->offset += str;
}
/* Lower bound is 1, as specified by the draft. */
GFC_DIMENSION_SET(f_ptr_out->dim[i], 1, ub, str);
}
f_ptr_out->offset *= -1;
/* All we know is the rank, so set it, leaving the rest alone.
Make NO assumptions about the state of dtype coming in! If we
shift right by TYPE_SHIFT bits we'll throw away the existing
rank. Then, shift left by the same number to shift in zeros
and or with the new rank. */
f_ptr_out->dtype = ((f_ptr_out->dtype >> GFC_DTYPE_TYPE_SHIFT)
<< GFC_DTYPE_TYPE_SHIFT) | shapeSize;
}
static void
eoshift0 (gfc_array_char * ret, const gfc_array_char * array,
int shift, const char * pbound, int which, index_type size,
const char *filler, index_type filler_len)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type roffset;
char * restrict rptr;
char *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type soffset;
const char *sptr;
const char *src;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
index_type len;
index_type n;
index_type arraysize;
/* The compiler cannot figure out that these are set, initialize
them to avoid warnings. */
len = 0;
soffset = 0;
roffset = 0;
arraysize = size0 ((array_t *) array);
if (ret->base_addr == NULL)
{
int i;
ret->offset = 0;
ret->dtype = array->dtype;
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);
}
/* xmalloc allocates a single byte for zero size. */
ret->base_addr = xmalloc (size * arraysize);
}
else if (unlikely (compile_options.bounds_check))
{
bounds_equal_extents ((array_t *) ret, (array_t *) array,
"return value", "EOSHIFT");
}
if (arraysize == 0)
return;
which = which - 1;
extent[0] = 1;
count[0] = 0;
sstride[0] = -1;
rstride[0] = -1;
n = 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;
if ((shift >= 0 ? shift : -shift) > len)
{
shift = len;
len = 0;
}
else
{
if (shift > 0)
len = len - shift;
else
len = len + shift;
}
while (rptr)
{
/* Do the shift for this dimension. */
if (shift > 0)
{
src = &sptr[shift * soffset];
dest = rptr;
}
else
{
src = sptr;
dest = &rptr[-shift * roffset];
}
for (n = 0; n < len; n++)
{
memcpy (dest, src, size);
dest += roffset;
src += soffset;
}
if (shift >= 0)
{
n = shift;
}
else
{
dest = rptr;
n = -shift;
}
if (pbound)
while (n--)
{
memcpy (dest, pbound, size);
dest += roffset;
}
else
while (n--)
{
index_type i;
if (filler_len == 1)
memset (dest, filler[0], size);
else
for (i = 0; i < size ; i += filler_len)
memcpy (&dest[i], filler, filler_len);
dest += roffset;
}
/* 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_i16 (gfc_array_i16 *ret, const gfc_array_i16 *vector,
const gfc_array_l1 *mask, const GFC_INTEGER_16 *fptr)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rs;
GFC_INTEGER_16 * restrict rptr;
/* v.* indicates the vector array. */
index_type vstride0;
GFC_INTEGER_16 *vptr;
/* Value for field, this is constant. */
const GFC_INTEGER_16 fval = *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
)
{
/* 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");
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(ret,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
rs *= extent[n];
}
ret->offset = 0;
ret->base_addr = xmallocarray (rs, sizeof (GFC_INTEGER_16));
}
else
{
dim = GFC_DESCRIPTOR_RANK (ret);
/* Initialize to avoid -Wmaybe-uninitialized complaints. */
rstride[0] = 1;
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(ret,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
}
if (rstride[0] == 0)
rstride[0] = 1;
}
if (empty)
return;
if (mstride[0] == 0)
mstride[0] = 1;
vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
if (vstride0 == 0)
vstride0 = 1;
rstride0 = rstride[0];
mstride0 = mstride[0];
rptr = ret->base_addr;
vptr = vector->base_addr;
while (rptr)
{
if (*mptr)
{
/* From vector. */
*rptr = *vptr;
vptr += vstride0;
}
else
{
/* From field. */
*rptr = fval;
}
/* Advance to the next element. */
rptr += rstride0;
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];
mptr -= mstride[n] * extent[n];
n++;
if (n >= dim)
{
/* Break out of the loop. */
rptr = NULL;
break;
}
else
{
count[n]++;
rptr += rstride[n];
mptr += mstride[n];
}
}
}
}
void
pack_r16 (gfc_array_r16 *ret, const gfc_array_r16 *array,
const gfc_array_l1 *mask, const gfc_array_r16 *vector)
{
/* r.* indicates the return array. */
index_type rstride0;
GFC_REAL_16 * restrict rptr;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
const GFC_REAL_16 *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->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
)
{
/* 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->data;
if (ret->data == NULL || 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. */
/* TODO: We could speed up pack easily in the case of only
few .TRUE. entries in MASK, by keeping track of where we
would be in the source array during the initial traversal
of MASK, and caching the pointers to those elements. Then,
supposed the number of elements is small enough, we would
only have to traverse the list, and copy those elements
into the result array. In the case of datatypes which fit
in one of the integer types we could also cache the
value instead of a pointer to it.
This approach might be bad from the point of view of
cache behavior in the case where our cache is not big
enough to hold all elements that have to be copied. */
const GFC_LOGICAL_1 *m = mptr;
total = 0;
if (zero_sized)
m = NULL;
while (m)
{
/* Test this element. */
if (*m)
total++;
/* Advance to the next element. */
m += mstride[0];
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 this product, but this is a
less frequently used path so probably not worth
it. */
m -= mstride[n] * extent[n];
n++;
if (n >= dim)
{
/* Break out of the loop. */
m = NULL;
break;
}
else
{
count[n]++;
m += mstride[n];
}
}
}
}
if (ret->data == NULL)
{
/* Setup the array descriptor. */
GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);
ret->offset = 0;
if (total == 0)
{
/* In this case, nothing remains to be done. */
ret->data = internal_malloc_size (1);
return;
}
else
ret->data = internal_malloc_size (sizeof (GFC_REAL_16) * total);
}
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->data;
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->data) / rstride0);
if (n > nelem)
{
sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
if (sstride0 == 0)
sstride0 = 1;
sptr = vector->data + sstride0 * nelem;
n -= nelem;
while (n--)
{
*rptr = *sptr;
rptr += rstride0;
sptr += sstride0;
}
}
}
}
static void
pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,
index_type size)
{
/* r.* indicates the return array. */
index_type rstride0;
char *rptr;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
const char *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ssize;
index_type nelem;
index_type total;
dim = GFC_DESCRIPTOR_RANK (array);
/* Initialize sstride[0] to avoid -Wmaybe-uninitialized
complaints. */
sstride[0] = size;
ssize = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
ssize *= extent[n];
}
if (sstride[0] == 0)
sstride[0] = size;
sstride0 = sstride[0];
if (ssize != 0)
sptr = array->base_addr;
else
sptr = NULL;
if (ret->base_addr == NULL)
{
/* Allocate the memory for the result. */
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
{
if (*mask)
{
/* The result array will have as many elements as the input
array. */
total = extent[0];
for (n = 1; n < dim; n++)
total *= extent[n];
}
else
/* The result array will be empty. */
total = 0;
}
/* Setup the array descriptor. */
GFC_DIMENSION_SET(ret->dim[0],0,total-1,1);
ret->offset = 0;
ret->base_addr = xmallocarray (total, size);
if (total == 0)
return;
}
rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
if (rstride0 == 0)
rstride0 = size;
rptr = ret->base_addr;
/* The remaining possibilities are now:
If MASK is .TRUE., we have to copy the source array into the
result array. We then have to fill it up with elements from VECTOR.
If MASK is .FALSE., we have to copy VECTOR into the result
array. If VECTOR were not present we would have already returned. */
if (*mask && ssize != 0)
{
while (sptr)
{
/* Add this element. */
memcpy (rptr, sptr, size);
rptr += rstride0;
/* Advance to the next element. */
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. */
sptr -= sstride[n] * extent[n];
n++;
if (n >= dim)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[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_BYTES(vector,0);
if (sstride0 == 0)
sstride0 = size;
sptr = vector->base_addr + sstride0 * nelem;
n -= nelem;
while (n--)
{
memcpy (rptr, sptr, size);
rptr += rstride0;
sptr += sstride0;
}
}
}
}
static void
reshape_internal (parray *ret, parray *source, shape_type *shape,
parray *pad, shape_type *order, index_type size)
{
/* r.* indicates the return array. */
index_type rcount[GFC_MAX_DIMENSIONS];
index_type rextent[GFC_MAX_DIMENSIONS];
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdim;
index_type rsize;
index_type rs;
index_type rex;
char * restrict rptr;
/* s.* indicates the source array. */
index_type scount[GFC_MAX_DIMENSIONS];
index_type sextent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type sdim;
index_type ssize;
const char *sptr;
/* p.* indicates the pad array. */
index_type pcount[GFC_MAX_DIMENSIONS];
index_type pextent[GFC_MAX_DIMENSIONS];
index_type pstride[GFC_MAX_DIMENSIONS];
index_type pdim;
index_type psize;
const char *pptr;
const char *src;
int n;
int dim;
int sempty, pempty, shape_empty;
index_type shape_data[GFC_MAX_DIMENSIONS];
rdim = GFC_DESCRIPTOR_EXTENT(shape,0);
if (rdim != GFC_DESCRIPTOR_RANK(ret))
runtime_error("rank of return array incorrect in RESHAPE intrinsic");
shape_empty = 0;
for (n = 0; n < rdim; n++)
{
shape_data[n] = shape->base_addr[n * GFC_DESCRIPTOR_STRIDE(shape,0)];
if (shape_data[n] <= 0)
{
shape_data[n] = 0;
shape_empty = 1;
}
}
if (ret->base_addr == NULL)
{
index_type alloc_size;
rs = 1;
for (n = 0; n < rdim; n++)
{
rex = shape_data[n];
GFC_DIMENSION_SET(ret->dim[n],0,rex - 1,rs);
rs *= rex;
}
ret->offset = 0;
if (unlikely (rs < 1))
alloc_size = 1;
else
alloc_size = rs * size;
ret->base_addr = xmalloc (alloc_size);
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim;
}
if (shape_empty)
return;
if (pad)
{
pdim = GFC_DESCRIPTOR_RANK (pad);
psize = 1;
pempty = 0;
for (n = 0; n < pdim; n++)
{
pcount[n] = 0;
pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n);
pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n);
if (pextent[n] <= 0)
{
pempty = 1;
pextent[n] = 0;
}
if (psize == pstride[n])
psize *= pextent[n];
else
psize = 0;
}
pptr = pad->base_addr;
}
else
{
pdim = 0;
psize = 1;
pempty = 1;
pptr = NULL;
}
if (unlikely (compile_options.bounds_check))
{
index_type ret_extent, source_extent;
rs = 1;
for (n = 0; n < rdim; n++)
{
rs *= shape_data[n];
ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
if (ret_extent != shape_data[n])
runtime_error("Incorrect extent in return value of RESHAPE"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) shape_data[n]);
}
source_extent = 1;
sdim = GFC_DESCRIPTOR_RANK (source);
for (n = 0; n < sdim; n++)
{
index_type se;
se = GFC_DESCRIPTOR_EXTENT(source,n);
source_extent *= se > 0 ? se : 0;
}
if (rs > source_extent && (!pad || pempty))
runtime_error("Incorrect size in SOURCE argument to RESHAPE"
" intrinsic: is %ld, should be %ld",
(long int) source_extent, (long int) rs);
if (order)
{
int seen[GFC_MAX_DIMENSIONS];
index_type v;
for (n = 0; n < rdim; n++)
seen[n] = 0;
for (n = 0; n < rdim; n++)
{
v = order->base_addr[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1;
if (v < 0 || v >= rdim)
runtime_error("Value %ld out of range in ORDER argument"
" to RESHAPE intrinsic", (long int) v + 1);
if (seen[v] != 0)
runtime_error("Duplicate value %ld in ORDER argument to"
" RESHAPE intrinsic", (long int) v + 1);
seen[v] = 1;
}
}
}
rsize = 1;
for (n = 0; n < rdim; n++)
{
if (order)
dim = order->base_addr[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1;
else
dim = n;
rcount[n] = 0;
rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim);
if (rextent[n] != shape_data[dim])
runtime_error ("shape and target do not conform");
if (rsize == rstride[n])
rsize *= rextent[n];
else
rsize = 0;
if (rextent[n] <= 0)
return;
}
sdim = GFC_DESCRIPTOR_RANK (source);
ssize = 1;
sempty = 0;
for (n = 0; n < sdim; n++)
{
scount[n] = 0;
sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
if (sextent[n] <= 0)
{
sempty = 1;
sextent[n] = 0;
}
if (ssize == sstride[n])
ssize *= sextent[n];
else
ssize = 0;
}
if (rsize != 0 && ssize != 0 && psize != 0)
{
rsize *= size;
ssize *= size;
psize *= size;
reshape_packed (ret->base_addr, rsize, source->base_addr, ssize,
pad ? pad->base_addr : NULL, psize);
return;
}
rptr = ret->base_addr;
src = sptr = source->base_addr;
rstride0 = rstride[0] * size;
sstride0 = sstride[0] * size;
if (sempty && pempty)
abort ();
if (sempty)
{
/* Pretend we are using the pad array the first time around, too. */
src = pptr;
sptr = pptr;
sdim = pdim;
for (dim = 0; dim < pdim; dim++)
{
scount[dim] = pcount[dim];
sextent[dim] = pextent[dim];
sstride[dim] = pstride[dim];
sstride0 = pstride[0] * size;
}
}
while (rptr)
{
/* Select between the source and pad arrays. */
memcpy(rptr, src, size);
/* Advance to the next element. */
rptr += rstride0;
src += sstride0;
rcount[0]++;
scount[0]++;
/* Advance to the next destination element. */
n = 0;
while (rcount[n] == rextent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
rcount[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
rptr -= rstride[n] * rextent[n] * size;
n++;
if (n == rdim)
{
/* Break out of the loop. */
rptr = NULL;
break;
}
else
{
rcount[n]++;
rptr += rstride[n] * size;
}
}
/* Advance to the next source element. */
n = 0;
while (scount[n] == sextent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
scount[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
src -= sstride[n] * sextent[n] * size;
n++;
if (n == sdim)
{
if (sptr && pad)
{
/* Switch to the pad array. */
sptr = NULL;
sdim = pdim;
for (dim = 0; dim < pdim; dim++)
{
scount[dim] = pcount[dim];
sextent[dim] = pextent[dim];
sstride[dim] = pstride[dim];
sstride0 = sstride[0] * size;
}
}
/* We now start again from the beginning of the pad array. */
src = pptr;
break;
}
else
{
scount[n]++;
src += sstride[n] * size;
}
}
}
}
static void
transpose_internal (gfc_array_char *ret, gfc_array_char *source)
{
/* r.* indicates the return array. */
index_type rxstride, rystride;
char *rptr;
/* s.* indicates the source array. */
index_type sxstride, systride;
const char *sptr;
index_type xcount, ycount;
index_type x, y;
index_type size;
assert (GFC_DESCRIPTOR_RANK (source) == 2
&& GFC_DESCRIPTOR_RANK (ret) == 2);
size = GFC_DESCRIPTOR_SIZE(ret);
if (ret->base_addr == NULL)
{
assert (ret->dtype == source->dtype);
GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1,
1);
GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1,
GFC_DESCRIPTOR_EXTENT(source, 1));
ret->base_addr = xmallocarray (size0 ((array_t*)ret), size);
ret->offset = 0;
}
else if (unlikely (compile_options.bounds_check))
{
index_type ret_extent, src_extent;
ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
src_extent = GFC_DESCRIPTOR_EXTENT(source,1);
if (src_extent != ret_extent)
runtime_error ("Incorrect extent in return value of TRANSPOSE"
" intrinsic in dimension 1: is %ld,"
" should be %ld", (long int) src_extent,
(long int) ret_extent);
ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1);
src_extent = GFC_DESCRIPTOR_EXTENT(source,0);
if (src_extent != ret_extent)
runtime_error ("Incorrect extent in return value of TRANSPOSE"
" intrinsic in dimension 2: is %ld,"
" should be %ld", (long int) src_extent,
(long int) ret_extent);
}
sxstride = GFC_DESCRIPTOR_STRIDE_BYTES(source,0);
systride = GFC_DESCRIPTOR_STRIDE_BYTES(source,1);
xcount = GFC_DESCRIPTOR_EXTENT(source,0);
ycount = GFC_DESCRIPTOR_EXTENT(source,1);
rxstride = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
rystride = GFC_DESCRIPTOR_STRIDE_BYTES(ret,1);
rptr = ret->base_addr;
sptr = source->base_addr;
for (y = 0; y < ycount; y++)
{
for (x = 0; x < xcount; x++)
{
memcpy (rptr, sptr, size);
sptr += sxstride;
rptr += rystride;
}
sptr += systride - (sxstride * xcount);
rptr += rxstride - (rystride * xcount);
}
}
