GFC_LOGICAL_4
associated (const gfc_array_void *pointer, const gfc_array_void *target)
{
int n, rank;
if (GFC_DESCRIPTOR_DATA (pointer) != GFC_DESCRIPTOR_DATA (target))
return 0;
if (GFC_DESCRIPTOR_DTYPE (pointer) != GFC_DESCRIPTOR_DTYPE (target))
return 0;
rank = GFC_DESCRIPTOR_RANK (pointer);
for (n = 0; n < rank; n++)
{
if (pointer->dim[n].stride != target->dim[n].stride)
return 0;
if ((pointer->dim[n].ubound - pointer->dim[n].lbound)
!= (target->dim[n].ubound - target->dim[n].lbound))
return 0;
}
return 1;
}
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;
}
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)
{
f_ptr_out->offset = 0;
shapeSize = 0;
/* shape's length (rank of the output array) */
shapeSize = shape->dim[0].ubound + 1 - shape->dim[0].lbound;
for (i = 0; i < shapeSize; i++)
{
/* Lower bound is 1, as specified by the draft. */
f_ptr_out->dim[i].lbound = 1;
/* Have to allow for the SHAPE array to be any valid kind for
an INTEGER type. */
#ifdef HAVE_GFC_INTEGER_1
if (GFC_DESCRIPTOR_SIZE (shape) == 1)
f_ptr_out->dim[i].ubound = ((GFC_INTEGER_1 *) (shape->data))[i];
#endif
#ifdef HAVE_GFC_INTEGER_2
if (GFC_DESCRIPTOR_SIZE (shape) == 2)
f_ptr_out->dim[i].ubound = ((GFC_INTEGER_2 *) (shape->data))[i];
#endif
#ifdef HAVE_GFC_INTEGER_4
if (GFC_DESCRIPTOR_SIZE (shape) == 4)
f_ptr_out->dim[i].ubound = ((GFC_INTEGER_4 *) (shape->data))[i];
#endif
#ifdef HAVE_GFC_INTEGER_8
if (GFC_DESCRIPTOR_SIZE (shape) == 8)
f_ptr_out->dim[i].ubound = ((GFC_INTEGER_8 *) (shape->data))[i];
#endif
#ifdef HAVE_GFC_INTEGER_16
if (GFC_DESCRIPTOR_SIZE (shape) == 16)
f_ptr_out->dim[i].ubound = ((GFC_INTEGER_16 *) (shape->data))[i];
#endif
}
/* Set the offset and strides.
offset is (sum of (dim[i].lbound * dim[i].stride) for all
dims) the -1 means we'll back the data pointer up that much
perhaps we could just realign the data pointer and not change
the offset? */
f_ptr_out->dim[0].stride = 1;
f_ptr_out->offset = f_ptr_out->dim[0].lbound * f_ptr_out->dim[0].stride;
for (i = 1; i < shapeSize; i++)
{
f_ptr_out->dim[i].stride = (f_ptr_out->dim[i-1].ubound + 1)
- f_ptr_out->dim[i-1].lbound;
f_ptr_out->offset += f_ptr_out->dim[i].lbound
* f_ptr_out->dim[i].stride;
}
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;
}
