static void
cshift0 (gfc_array_char * ret, const gfc_array_char * array,
ssize_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;
int whichloop;
if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
which = which - 1;
extent[0] = 1;
count[0] = 0;
n = 0;
/* The values assigned here must match the cases in the inner loop. */
whichloop = 0;
switch (GFC_DESCRIPTOR_TYPE (array))
{
case GFC_DTYPE_LOGICAL:
case GFC_DTYPE_INTEGER:
case GFC_DTYPE_REAL:
if (size == sizeof (int))
whichloop = 1;
else if (size == sizeof (long))
whichloop = 2;
else if (size == sizeof (double))
whichloop = 3;
else if (size == sizeof (long double))
whichloop = 4;
break;
case GFC_DTYPE_COMPLEX:
if (size == sizeof (_Complex float))
whichloop = 5;
else if (size == sizeof (_Complex double))
whichloop = 6;
break;
default:
break;
}
/* Initialized for avoiding compiler warnings. */
roffset = size;
soffset = size;
len = 0;
if (ret->data == NULL)
{
int i;
index_type arraysize = size0 ((array_t *)array);
ret->offset = 0;
ret->dtype = array->dtype;
for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
{
ret->dim[i].lbound = 0;
ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
if (i == 0)
ret->dim[i].stride = 1;
else
ret->dim[i].stride = (ret->dim[i-1].ubound + 1)
* ret->dim[i-1].stride;
}
if (arraysize > 0)
ret->data = internal_malloc_size (size * arraysize);
else
{
ret->data = internal_malloc_size (1);
return;
}
}
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
if (dim == which)
{
roffset = ret->dim[dim].stride * size;
if (roffset == 0)
roffset = size;
soffset = array->dim[dim].stride * size;
if (soffset == 0)
soffset = size;
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
}
else
{
count[n] = 0;
extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
rstride[n] = ret->dim[dim].stride * size;
sstride[n] = array->dim[dim].stride * size;
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->data;
sptr = array->data;
shift = shift % (ssize_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. We can speed this up a tad for common cases of
fundamental types. */
switch (whichloop)
{
case 0:
{
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;
}
}
break;
case 1:
copy_loop_int (rptr, sptr, roffset, soffset, len, shift);
break;
case 2:
copy_loop_long (rptr, sptr, roffset, soffset, len, shift);
break;
case 3:
copy_loop_double (rptr, sptr, roffset, soffset, len, shift);
break;
case 4:
copy_loop_ldouble (rptr, sptr, roffset, soffset, len, shift);
break;
case 5:
copy_loop_cfloat (rptr, sptr, roffset, soffset, len, shift);
break;
case 6:
copy_loop_cdouble (rptr, sptr, roffset, soffset, len, shift);
break;
default:
abort ();
}
}
/* 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 *
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;
int type;
if (source->dim[0].stride == 0)
{
source->dim[0].stride = 1;
return source->data;
}
type = GFC_DESCRIPTOR_TYPE (source);
size = GFC_DESCRIPTOR_SIZE (source);
switch (type)
{
case GFC_DTYPE_INTEGER:
case GFC_DTYPE_LOGICAL:
case GFC_DTYPE_REAL:
switch (size)
{
case 4:
return internal_pack_4 ((gfc_array_i4 *)source);
case 8:
return internal_pack_8 ((gfc_array_i8 *)source);
}
break;
case GFC_DTYPE_COMPLEX:
switch (size)
{
case 8:
return internal_pack_c4 ((gfc_array_c4 *)source);
case 16:
return internal_pack_c8 ((gfc_array_c8 *)source);
}
break;
default:
break;
}
dim = GFC_DESCRIPTOR_RANK (source);
ssize = 1;
packed = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
stride[n] = source->dim[n].stride;
extent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
if (extent[n] <= 0)
{
/* Do nothing. */
packed = 1;
break;
}
if (ssize != stride[n])
packed = 0;
ssize *= extent[n];
}
if (packed)
return source->data;
/* Allocate storage for the destination. */
destptr = internal_malloc_size (ssize * size);
dest = (char *)destptr;
src = source->data;
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 proabably 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;
}
