int
gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
{
gfc_component *cmp;
gfc_constructor *head = NULL, *tail = NULL;
int ptr;
tree type;
/* The attributes of the derived type need to be bolted to the floor. */
result->expr_type = EXPR_STRUCTURE;
type = gfc_typenode_for_spec (&result->ts);
cmp = result->ts.derived->components;
/* Run through the derived type components. */
for (;cmp; cmp = cmp->next)
{
if (head == NULL)
head = tail = gfc_get_constructor ();
else
{
tail->next = gfc_get_constructor ();
tail = tail->next;
}
/* The constructor points to the component. */
tail->n.component = cmp;
tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
&result->where);
tail->expr->ts = cmp->ts;
/* Copy shape, if needed. */
if (cmp->as && cmp->as->rank)
{
int n;
tail->expr->expr_type = EXPR_ARRAY;
tail->expr->rank = cmp->as->rank;
tail->expr->shape = gfc_get_shape (tail->expr->rank);
for (n = 0; n < tail->expr->rank; n++)
{
mpz_init_set_ui (tail->expr->shape[n], 1);
mpz_add (tail->expr->shape[n], tail->expr->shape[n],
cmp->as->upper[n]->value.integer);
mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
cmp->as->lower[n]->value.integer);
}
}
ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
tail->expr);
result->value.constructor = head;
}
return int_size_in_bytes (type);
}
static int
encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
{
gfc_constructor *ctr;
gfc_component *cmp;
int ptr;
tree type;
type = gfc_typenode_for_spec (&source->ts);
ctr = source->value.constructor;
cmp = source->ts.derived->components;
for (;ctr; ctr = ctr->next, cmp = cmp->next)
{
gcc_assert (cmp);
if (!ctr->expr)
continue;
ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
if (ctr->expr->expr_type == EXPR_NULL)
memset (&buffer[ptr], 0,
int_size_in_bytes (TREE_TYPE (cmp->backend_decl)));
else
gfc_target_encode_expr (ctr->expr, &buffer[ptr],
buffer_size - ptr);
}
return int_size_in_bytes (type);
}
static HOST_WIDE_INT
calculate_offset (gfc_expr *e)
{
HOST_WIDE_INT n, element_size, offset;
gfc_typespec *element_type;
gfc_ref *reference;
offset = 0;
element_type = &e->symtree->n.sym->ts;
for (reference = e->ref; reference; reference = reference->next)
switch (reference->type)
{
case REF_ARRAY:
switch (reference->u.ar.type)
{
case AR_FULL:
break;
case AR_ELEMENT:
n = element_number (&reference->u.ar);
if (element_type->type == BT_CHARACTER)
gfc_conv_const_charlen (element_type->u.cl);
element_size =
int_size_in_bytes (gfc_typenode_for_spec (element_type));
offset += n * element_size;
break;
default:
gfc_error ("Bad array reference at %L", &e->where);
}
break;
case REF_SUBSTRING:
if (reference->u.ss.start != NULL)
offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
break;
default:
gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
&e->where);
}
return offset;
}
size_t
gfc_target_expr_size (gfc_expr *e)
{
tree type;
gcc_assert (e != NULL);
if (e->expr_type == EXPR_ARRAY)
return size_array (e);
switch (e->ts.type)
{
case BT_INTEGER:
return size_integer (e->ts.kind);
case BT_REAL:
return size_float (e->ts.kind);
case BT_COMPLEX:
return size_complex (e->ts.kind);
case BT_LOGICAL:
return size_logical (e->ts.kind);
case BT_CHARACTER:
if (e->expr_type == EXPR_SUBSTRING && e->ref)
{
int start, end;
gfc_extract_int (e->ref->u.ss.start, &start);
gfc_extract_int (e->ref->u.ss.end, &end);
return size_character (MAX(end - start + 1, 0), e->ts.kind);
}
else
return size_character (e->value.character.length, e->ts.kind);
case BT_HOLLERITH:
return e->representation.length;
case BT_DERIVED:
type = gfc_typenode_for_spec (&e->ts);
return int_size_in_bytes (type);
default:
gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
return 0;
}
}
tree
gfc_conv_constant_to_tree (gfc_expr * expr)
{
tree res;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
/* If it is has a prescribed memory representation, we build a string
constant and VIEW_CONVERT to its type. */
switch (expr->ts.type)
{
case BT_INTEGER:
if (expr->representation.string)
return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_int_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
else
return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
case BT_REAL:
if (expr->representation.string)
return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_real_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
else
return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);
case BT_LOGICAL:
if (expr->representation.string)
{
tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_int_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
if (!integer_zerop (tmp) && !integer_onep (tmp))
gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"
" has undefined result at %L", &expr->where);
return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
}
else
return build_int_cst (gfc_get_logical_type (expr->ts.kind),
expr->value.logical);
case BT_COMPLEX:
if (expr->representation.string)
return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_complex_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
else
{
tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex),
expr->ts.kind, expr->is_snan);
tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex),
expr->ts.kind, expr->is_snan);
return build_complex (gfc_typenode_for_spec (&expr->ts),
real, imag);
}
case BT_CHARACTER:
res = gfc_build_wide_string_const (expr->ts.kind,
expr->value.character.length,
expr->value.character.string);
return res;
case BT_HOLLERITH:
return gfc_build_string_const (expr->representation.length,
expr->representation.string);
default:
fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
gfc_typename (&expr->ts));
}
}
int
gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
{
gfc_component *cmp;
gfc_constructor *head = NULL, *tail = NULL;
int ptr;
tree type;
/* The attributes of the derived type need to be bolted to the floor. */
result->expr_type = EXPR_STRUCTURE;
type = gfc_typenode_for_spec (&result->ts);
cmp = result->ts.u.derived->components;
/* Run through the derived type components. */
for (;cmp; cmp = cmp->next)
{
if (head == NULL)
head = tail = gfc_get_constructor ();
else
{
tail->next = gfc_get_constructor ();
tail = tail->next;
}
/* The constructor points to the component. */
tail->n.component = cmp;
tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
&result->where);
tail->expr->ts = cmp->ts;
/* Copy shape, if needed. */
if (cmp->as && cmp->as->rank)
{
int n;
tail->expr->expr_type = EXPR_ARRAY;
tail->expr->rank = cmp->as->rank;
tail->expr->shape = gfc_get_shape (tail->expr->rank);
for (n = 0; n < tail->expr->rank; n++)
{
mpz_init_set_ui (tail->expr->shape[n], 1);
mpz_add (tail->expr->shape[n], tail->expr->shape[n],
cmp->as->upper[n]->value.integer);
mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
cmp->as->lower[n]->value.integer);
}
}
/* Calculate the offset, which consists of the the FIELD_OFFSET in
bytes, which appears in multiples of DECL_OFFSET_ALIGN-bit-sized,
and additional bits of FIELD_BIT_OFFSET. The code assumes that all
sizes of the components are multiples of BITS_PER_UNIT,
i.e. there are, e.g., no bit fields. */
ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl));
gcc_assert (ptr % 8 == 0);
ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
tail->expr);
result->value.constructor = head;
}
return int_size_in_bytes (type);
}
static tree
gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
bool fini_coarray, gfc_expr *class_size)
{
stmtblock_t block;
gfc_se se;
tree final_fndecl, array, size, tmp;
symbol_attribute attr;
gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
gcc_assert (var);
gfc_start_block (&block);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, final_wrapper);
final_fndecl = se.expr;
if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
if (ts.type == BT_DERIVED)
{
tree elem_size;
gcc_assert (!class_size);
elem_size = gfc_typenode_for_spec (&ts);
elem_size = TYPE_SIZE_UNIT (elem_size);
size = fold_convert (gfc_array_index_type, elem_size);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
if (var->rank)
{
se.descriptor_only = 1;
gfc_conv_expr_descriptor (&se, var);
array = se.expr;
}
else
{
gfc_conv_expr (&se, var);
gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
array = se.expr;
/* No copy back needed, hence set attr's allocatable/pointer
to zero. */
gfc_clear_attr (&attr);
gfc_init_se (&se, NULL);
array = gfc_conv_scalar_to_descriptor (&se, array, attr);
gcc_assert (se.post.head == NULL_TREE);
}
}
else
{
gfc_expr *array_expr;
gcc_assert (class_size);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, class_size);
gfc_add_block_to_block (&block, &se.pre);
gcc_assert (se.post.head == NULL_TREE);
size = se.expr;
array_expr = gfc_copy_expr (var);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
if (array_expr->rank)
{
gfc_add_class_array_ref (array_expr);
se.descriptor_only = 1;
gfc_conv_expr_descriptor (&se, array_expr);
array = se.expr;
}
else
{
gfc_add_data_component (array_expr);
gfc_conv_expr (&se, array_expr);
gfc_add_block_to_block (&block, &se.pre);
gcc_assert (se.post.head == NULL_TREE);
array = se.expr;
if (TREE_CODE (array) == ADDR_EXPR
&& POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
tmp = TREE_OPERAND (array, 0);
if (!gfc_is_coarray (array_expr))
{
/* No copy back needed, hence set attr's allocatable/pointer
to zero. */
gfc_clear_attr (&attr);
gfc_init_se (&se, NULL);
array = gfc_conv_scalar_to_descriptor (&se, array, attr);
}
gcc_assert (se.post.head == NULL_TREE);
}
gfc_free_expr (array_expr);
}
if (!POINTER_TYPE_P (TREE_TYPE (array)))
array = gfc_build_addr_expr (NULL, array);
gfc_add_block_to_block (&block, &se.pre);
tmp = build_call_expr_loc (input_location,
final_fndecl, 3, array,
size, fini_coarray ? boolean_true_node
: boolean_false_node);
gfc_add_block_to_block (&block, &se.post);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
