/* Expression translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
- Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "ggc.h"
#include "toplev.h"
#include "real.h"
-#include "tree-gimple.h"
+#include "gimple.h"
#include "langhooks.h"
#include "flags.h"
#include "gfortran.h"
/* We need a temporary for this result. */
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify_expr (&se->pre, var, se->expr);
+ gfc_add_modify (&se->pre, var, se->expr);
se->expr = var;
}
tmp = fold_convert (tmp, build_fold_indirect_ref (se->expr));
/* Test for a NULL value. */
- tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp, integer_one_node);
+ tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
+ fold_convert (TREE_TYPE (tmp), integer_one_node));
tmp = gfc_evaluate_now (tmp, &se->pre);
se->expr = build_fold_addr_expr (tmp);
}
return length;
}
-
+
+/* For each character array constructor subexpression without a ts.cl->length,
+ replace it by its first element (if there aren't any elements, the length
+ should already be set to zero). */
+
+static void
+flatten_array_ctors_without_strlen (gfc_expr* e)
+{
+ gfc_actual_arglist* arg;
+ gfc_constructor* c;
+
+ if (!e)
+ return;
+
+ switch (e->expr_type)
+ {
+
+ case EXPR_OP:
+ flatten_array_ctors_without_strlen (e->value.op.op1);
+ flatten_array_ctors_without_strlen (e->value.op.op2);
+ break;
+
+ case EXPR_COMPCALL:
+ /* TODO: Implement as with EXPR_FUNCTION when needed. */
+ gcc_unreachable ();
+
+ case EXPR_FUNCTION:
+ for (arg = e->value.function.actual; arg; arg = arg->next)
+ flatten_array_ctors_without_strlen (arg->expr);
+ break;
+
+ case EXPR_ARRAY:
+
+ /* We've found what we're looking for. */
+ if (e->ts.type == BT_CHARACTER && !e->ts.cl->length)
+ {
+ gfc_expr* new_expr;
+ gcc_assert (e->value.constructor);
+
+ new_expr = e->value.constructor->expr;
+ e->value.constructor->expr = NULL;
+
+ flatten_array_ctors_without_strlen (new_expr);
+ gfc_replace_expr (e, new_expr);
+ break;
+ }
+
+ /* Otherwise, fall through to handle constructor elements. */
+ case EXPR_STRUCTURE:
+ for (c = e->value.constructor; c; c = c->next)
+ flatten_array_ctors_without_strlen (c->expr);
+ break;
+
+ default:
+ break;
+
+ }
+}
+
/* Generate code to initialize a string length variable. Returns the
- value. */
+ value. For array constructors, cl->length might be NULL and in this case,
+ the first element of the constructor is needed. expr is the original
+ expression so we can access it but can be NULL if this is not needed. */
void
-gfc_conv_string_length (gfc_charlen * cl, stmtblock_t * pblock)
+gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
{
gfc_se se;
gfc_init_se (&se, NULL);
+
+ /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
+ "flatten" array constructors by taking their first element; all elements
+ should be the same length or a cl->length should be present. */
+ if (!cl->length)
+ {
+ gfc_expr* expr_flat;
+ gcc_assert (expr);
+
+ expr_flat = gfc_copy_expr (expr);
+ flatten_array_ctors_without_strlen (expr_flat);
+ gfc_resolve_expr (expr_flat);
+
+ gfc_conv_expr (&se, expr_flat);
+ gfc_add_block_to_block (pblock, &se.pre);
+ cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
+
+ gfc_free_expr (expr_flat);
+ return;
+ }
+
+ /* Convert cl->length. */
+
+ gcc_assert (cl->length);
+
gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
build_int_cst (gfc_charlen_type_node, 0));
gfc_add_block_to_block (pblock, &se.pre);
if (cl->backend_decl)
- gfc_add_modify_expr (pblock, cl->backend_decl, se.expr);
+ gfc_add_modify (pblock, cl->backend_decl, se.expr);
else
cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
}
se->string_length = tmp;
}
- if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
+ if (c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
se->expr = build_fold_indirect_ref (se->expr);
}
+/* This function deals with component references to components of the
+ parent type for derived type extensons. */
+static void
+conv_parent_component_references (gfc_se * se, gfc_ref * ref)
+{
+ gfc_component *c;
+ gfc_component *cmp;
+ gfc_symbol *dt;
+ gfc_ref parent;
+
+ dt = ref->u.c.sym;
+ c = ref->u.c.component;
+
+ /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
+ parent.type = REF_COMPONENT;
+ parent.next = NULL;
+ parent.u.c.sym = dt;
+ parent.u.c.component = dt->components;
+
+ if (dt->attr.extension && dt->components)
+ {
+ /* Return if the component is not in the parent type. */
+ for (cmp = dt->components->next; cmp; cmp = cmp->next)
+ if (strcmp (c->name, cmp->name) == 0)
+ return;
+
+ /* Otherwise build the reference and call self. */
+ gfc_conv_component_ref (se, &parent);
+ parent.u.c.sym = dt->components->ts.derived;
+ parent.u.c.component = c;
+ conv_parent_component_references (se, &parent);
+ }
+}
+
/* Return the contents of a variable. Also handles reference/pointer
variables (all Fortran pointer references are implicit). */
break;
case REF_COMPONENT:
+ if (ref->u.c.sym->attr.extension)
+ conv_parent_component_references (se, ref);
+
gfc_conv_component_ref (se, ref);
break;
fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
fold_convert (TREE_TYPE (len),
TYPE_SIZE (type))));
- gfc_add_modify_expr (&se->pre, var, tmp);
+ gfc_add_modify (&se->pre, var, tmp);
/* Free the temporary afterwards. */
tmp = gfc_call_free (convert (pvoid_type_node, var));
for (sym = mapping->syms; sym; sym = nextsym)
{
nextsym = sym->next;
+ sym->new_sym->n.sym->formal = NULL;
gfc_free_symbol (sym->new_sym->n.sym);
gfc_free_expr (sym->expr);
gfc_free (sym->new_sym);
type = gfc_get_nodesc_array_type (type, sym->as, packed);
var = gfc_create_var (type, "ifm");
- gfc_add_modify_expr (block, var, fold_convert (type, data));
+ gfc_add_modify (block, var, fold_convert (type, data));
return var;
}
/* Create a new symbol to represent the actual argument. */
new_sym = gfc_new_symbol (sym->name, NULL);
new_sym->ts = sym->ts;
+ new_sym->as = gfc_copy_array_spec (sym->as);
new_sym->attr.referenced = 1;
new_sym->attr.dimension = sym->attr.dimension;
new_sym->attr.pointer = sym->attr.pointer;
new_sym->attr.flavor = sym->attr.flavor;
new_sym->attr.function = sym->attr.function;
+ /* Ensure that the interface is available and that
+ descriptors are passed for array actual arguments. */
+ if (sym->attr.flavor == FL_PROCEDURE)
+ {
+ new_sym->formal = expr->symtree->n.sym->formal;
+ new_sym->attr.always_explicit
+ = expr->symtree->n.sym->attr.always_explicit;
+ }
+
/* Create a fake symtree for it. */
root = NULL;
new_symtree = gfc_new_symtree (&root, sym->name);
gfc_apply_interface_mapping_to_expr (mapping, expr);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
-
+ se.expr = fold_convert (gfc_charlen_type_node, se.expr);
se.expr = gfc_evaluate_now (se.expr, &se.pre);
gfc_add_block_to_block (pre, &se.pre);
gfc_add_block_to_block (post, &se.post);
/* Convert intrinsic function calls into result expressions. */
+
static bool
-gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping * mapping)
+gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
{
gfc_symbol *sym;
gfc_expr *new_expr;
else
arg2 = NULL;
- sym = arg1->symtree->n.sym;
+ sym = arg1->symtree->n.sym;
if (sym->attr.dummy)
return false;
case GFC_ISYM_LEN:
/* TODO figure out why this condition is necessary. */
if (sym->attr.function
- && arg1->ts.cl->length->expr_type != EXPR_CONSTANT
- && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)
+ && (arg1->ts.cl->length == NULL
+ || (arg1->ts.cl->length->expr_type != EXPR_CONSTANT
+ && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)))
return false;
new_expr = gfc_copy_expr (arg1->ts.cl->length);
for (; d < dup; d++)
{
gfc_expr *tmp;
+
+ if (!sym->as->upper[d] || !sym->as->lower[d])
+ {
+ gfc_free_expr (new_expr);
+ return false;
+ }
+
tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
if (new_expr)
gcc_unreachable ();
if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
- new_expr = gfc_copy_expr (sym->as->lower[d]);
+ {
+ if (sym->as->lower[d])
+ new_expr = gfc_copy_expr (sym->as->lower[d]);
+ }
else
- new_expr = gfc_copy_expr (sym->as->upper[d]);
+ {
+ if (sym->as->upper[d])
+ new_expr = gfc_copy_expr (sym->as->upper[d]);
+ }
break;
default:
case EXPR_STRUCTURE:
gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
break;
+
+ case EXPR_COMPCALL:
+ gcc_unreachable ();
+ break;
}
return;
/* Build an ss for the temporary. */
if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
- gfc_conv_string_length (expr->ts.cl, &parmse->pre);
+ gfc_conv_string_length (expr->ts.cl, expr, &parmse->pre);
base_type = gfc_typenode_for_spec (&expr->ts);
if (GFC_ARRAY_TYPE_P (base_type)
tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
tmp_index, rse.loop->from[0]);
- gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
+ gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
rse.loop->loopvar[0], offset);
&& parmse.string_length == NULL_TREE
&& e->ts.type == BT_PROCEDURE
&& e->symtree->n.sym->ts.type == BT_CHARACTER
- && e->symtree->n.sym->ts.cl->length != NULL)
+ && e->symtree->n.sym->ts.cl->length != NULL
+ && e->symtree->n.sym->ts.cl->length->expr_type == EXPR_CONSTANT)
{
gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
gfc_add_block_to_block (&post, &parmse.post);
/* Allocated allocatable components of derived types must be
- deallocated for INTENT(OUT) dummy arguments and non-variable
- scalars. Non-variable arrays are dealt with in trans-array.c
- (gfc_conv_array_parameter). */
+ deallocated for non-variable scalars. Non-variable arrays are
+ dealt with in trans-array.c(gfc_conv_array_parameter). */
if (e && e->ts.type == BT_DERIVED
&& e->ts.derived->attr.alloc_comp
- && ((formal && formal->sym->attr.intent == INTENT_OUT)
- ||
- (e->expr_type != EXPR_VARIABLE && !e->rank)))
+ && (e->expr_type != EXPR_VARIABLE && !e->rank))
{
int parm_rank;
tmp = build_fold_indirect_ref (parmse.expr);
case (SCALAR_POINTER):
tmp = build_fold_indirect_ref (tmp);
break;
- case (ARRAY):
- tmp = parmse.expr;
- break;
}
- tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
- if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
- tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
- tmp, build_empty_stmt ());
-
- if (e->expr_type != EXPR_VARIABLE)
- /* Don't deallocate non-variables until they have been used. */
- gfc_add_expr_to_block (&se->post, tmp);
- else
- {
- gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
- gfc_add_expr_to_block (&se->pre, tmp);
- }
+ tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
+ gfc_add_expr_to_block (&se->post, tmp);
}
/* Character strings are passed as two parameters, a length and a
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
ts = sym->ts;
- if (ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
+ if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
+ se->string_length = build_int_cst (gfc_charlen_type_node, 1);
+ else if (ts.type == BT_CHARACTER)
{
if (sym->ts.cl->length == NULL)
{
mustn't be deallocated. */
callee_alloc = sym->attr.allocatable || sym->attr.pointer;
gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
- false, !sym->attr.pointer, callee_alloc,
- &se->ss->expr->where);
+ NULL_TREE, false, !sym->attr.pointer,
+ callee_alloc, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
tmp = info->descriptor;
/* Initialize variables. */
gfc_init_block (&block);
i = gfc_create_var (sizetype, "i");
- gfc_add_modify_expr (&block, i, fold_convert (sizetype, size));
+ gfc_add_modify (&block, i, fold_convert (sizetype, size));
el = gfc_create_var (build_pointer_type (type), "el");
- gfc_add_modify_expr (&block, el, fold_convert (TREE_TYPE (el), start));
+ gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
exit_label = gfc_build_label_decl (NULL_TREE);
TREE_USED (exit_label) = 1;
gfc_add_expr_to_block (&loop, tmp);
/* Assignment. */
- gfc_add_modify_expr (&loop, fold_build1 (INDIRECT_REF, type, el),
+ gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
build_int_cst (type,
lang_hooks.to_target_charset (' ')));
/* Increment loop variables. */
- gfc_add_modify_expr (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
+ gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
TYPE_SIZE_UNIT (type)));
- gfc_add_modify_expr (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
+ gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
TREE_TYPE (el), el,
TYPE_SIZE_UNIT (type)));
if (dsc != NULL_TREE && ssc != NULL_TREE
&& TREE_TYPE (dsc) == TREE_TYPE (ssc))
{
- gfc_add_modify_expr (block, dsc, ssc);
+ gfc_add_modify (block, dsc, ssc);
return;
}
/* For non-default character kinds, we have to multiply the string
length by the base type size. */
chartype = gfc_get_char_type (dkind);
- slen = fold_build2 (MULT_EXPR, size_type_node, slen,
- TYPE_SIZE_UNIT (chartype));
- dlen = fold_build2 (MULT_EXPR, size_type_node, dlen,
- TYPE_SIZE_UNIT (chartype));
+ slen = fold_build2 (MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, slen),
+ fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
+ dlen = fold_build2 (MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, dlen),
+ fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
if (dlength)
dest = fold_convert (pvoid_type_node, dest);
gfc_conv_expr (&lse, args->expr);
gfc_add_block_to_block (&se->pre, &lse.pre);
- gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
+ gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
gfc_add_block_to_block (&se->pre, &lse.post);
}
gfc_start_block (&block);
- if (cm->pointer)
+ if (cm->attr.pointer)
{
gfc_init_se (&se, NULL);
/* Pointer component. */
- if (cm->dimension)
+ if (cm->attr.dimension)
{
/* Array pointer. */
if (expr->expr_type == EXPR_NULL)
se.want_pointer = 1;
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&block, &se.pre);
- gfc_add_modify_expr (&block, dest,
+ gfc_add_modify (&block, dest,
fold_convert (TREE_TYPE (dest), se.expr));
gfc_add_block_to_block (&block, &se.post);
}
}
- else if (cm->dimension)
+ else if (cm->attr.dimension)
{
- if (cm->allocatable && expr->expr_type == EXPR_NULL)
+ if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
- else if (cm->allocatable)
+ else if (cm->attr.allocatable)
{
tree tmp2;
gfc_add_block_to_block (&block, &se.pre);
tmp = fold_convert (TREE_TYPE (dest), se.expr);
- gfc_add_modify_expr (&block, dest, tmp);
+ gfc_add_modify (&block, dest, tmp);
if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
cm->as->rank);
gfc_add_expr_to_block (&block, tmp);
-
gfc_add_block_to_block (&block, &se.post);
- gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
+
+ if (expr->expr_type != EXPR_VARIABLE)
+ gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
/* Shift the lbound and ubound of temporaries to being unity, rather
than zero, based. Calculate the offset for all cases. */
offset = gfc_conv_descriptor_offset (dest);
- gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
+ gfc_add_modify (&block, offset, gfc_index_zero_node);
tmp2 =gfc_create_var (gfc_array_index_type, NULL);
for (n = 0; n < expr->rank; n++)
{
tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
- gfc_add_modify_expr (&block, tmp,
+ gfc_add_modify (&block, tmp,
fold_build2 (PLUS_EXPR,
gfc_array_index_type,
span, gfc_index_one_node));
tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
- gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
+ gfc_add_modify (&block, tmp, gfc_index_one_node);
}
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
gfc_conv_descriptor_lbound (dest,
gfc_rank_cst[n]),
gfc_conv_descriptor_stride (dest,
gfc_rank_cst[n]));
- gfc_add_modify_expr (&block, tmp2, tmp);
+ gfc_add_modify (&block, tmp2, tmp);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
- gfc_add_modify_expr (&block, offset, tmp);
+ gfc_add_modify (&block, offset, tmp);
+ }
+
+ if (expr->expr_type == EXPR_FUNCTION
+ && expr->value.function.isym
+ && expr->value.function.isym->conversion
+ && expr->value.function.actual->expr
+ && expr->value.function.actual->expr->expr_type
+ == EXPR_VARIABLE)
+ {
+ /* If a conversion expression has a null data pointer
+ argument, nullify the allocatable component. */
+ gfc_symbol *s;
+ tree non_null_expr;
+ tree null_expr;
+ s = expr->value.function.actual->expr->symtree->n.sym;
+ if (s->attr.allocatable || s->attr.pointer)
+ {
+ non_null_expr = gfc_finish_block (&block);
+ gfc_start_block (&block);
+ gfc_conv_descriptor_data_set (&block, dest,
+ null_pointer_node);
+ null_expr = gfc_finish_block (&block);
+ tmp = gfc_conv_descriptor_data_get (s->backend_decl);
+ tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
+ return build3_v (COND_EXPR, tmp, null_expr,
+ non_null_expr);
+ }
}
}
else
{
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
- gfc_add_modify_expr (&block, dest,
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_modify (&block, dest,
fold_convert (TREE_TYPE (dest), se.expr));
+ gfc_add_block_to_block (&block, &se.post);
}
else
{
{
/* Skip absent members in default initializers. */
if (!c->expr)
- continue;
+ continue;
- /* Update the type/kind of the expression if it represents either
- C_NULL_PTR or C_NULL_FUNPTR. This is done here because this may
- be the first place reached for initializing output variables that
- have components of type C_PTR/C_FUNPTR that are initialized. */
- if (c->expr->ts.type == BT_DERIVED && c->expr->ts.derived
- && c->expr->ts.derived->attr.is_iso_c)
- {
- c->expr->expr_type = EXPR_NULL;
- c->expr->ts.type = c->expr->ts.derived->ts.type;
- c->expr->ts.f90_type = c->expr->ts.derived->ts.f90_type;
- c->expr->ts.kind = c->expr->ts.derived->ts.kind;
- }
-
field = cm->backend_decl;
tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
dest, field, NULL_TREE);
components. Although the latter have a default initializer
of EXPR_NULL,... by default, the static nullify is not needed
since this is done every time we come into scope. */
- if (!c->expr || cm->allocatable)
+ if (!c->expr || cm->attr.allocatable)
continue;
val = gfc_conv_initializer (c->expr, &cm->ts,
- TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
+ TREE_TYPE (cm->backend_decl), cm->attr.dimension, cm->attr.pointer);
/* Append it to the constructor list. */
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
if (se->post.head)
{
val = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify_expr (&se->pre, val, se->expr);
+ gfc_add_modify (&se->pre, val, se->expr);
se->expr = val;
gfc_add_block_to_block (&se->pre, &se->post);
}
if (se->post.head)
{
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify_expr (&se->pre, var, se->expr);
+ gfc_add_modify (&se->pre, var, se->expr);
gfc_add_block_to_block (&se->pre, &se->post);
se->expr = var;
}
se->want_pointer = 1;
gfc_conv_expr (se, expr);
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify_expr (&se->pre, var, se->expr);
+ gfc_add_modify (&se->pre, var, se->expr);
se->expr = var;
return;
}
else
{
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify_expr (&se->pre, var, se->expr);
+ gfc_add_modify (&se->pre, var, se->expr);
}
gfc_add_block_to_block (&se->pre, &se->post);
tree tmp;
tree decl;
-
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
- gfc_add_modify_expr (&block, lse.expr,
+
+ /* Check character lengths if character expression. The test is only
+ really added if -fbounds-check is enabled. */
+ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+ {
+ gcc_assert (expr2->ts.type == BT_CHARACTER);
+ gcc_assert (lse.string_length && rse.string_length);
+ gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+ lse.string_length, rse.string_length,
+ &block);
+ }
+
+ gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
+
gfc_add_block_to_block (&block, &rse.post);
gfc_add_block_to_block (&block, &lse.post);
}
else
{
+ tree strlen_lhs;
+ tree strlen_rhs = NULL_TREE;
+
/* Array pointer. */
gfc_conv_expr_descriptor (&lse, expr1, lss);
+ strlen_lhs = lse.string_length;
switch (expr2->expr_type)
{
case EXPR_NULL:
case EXPR_VARIABLE:
/* Assign directly to the pointer's descriptor. */
- lse.direct_byref = 1;
+ lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
+ strlen_rhs = lse.string_length;
/* If this is a subreference array pointer assignment, use the rhs
descriptor element size for the lhs span. */
tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
if (!INTEGER_CST_P (tmp))
- gfc_add_block_to_block (&lse.post, &rse.pre);
- gfc_add_modify_expr (&lse.post, GFC_DECL_SPAN(decl), tmp);
+ gfc_add_block_to_block (&lse.post, &rse.pre);
+ gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
}
break;
lse.expr = tmp;
lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
- gfc_add_modify_expr (&lse.pre, desc, tmp);
+ strlen_rhs = lse.string_length;
+ gfc_add_modify (&lse.pre, desc, tmp);
break;
- }
+ }
+
gfc_add_block_to_block (&block, &lse.pre);
+
+ /* Check string lengths if applicable. The check is only really added
+ to the output code if -fbounds-check is enabled. */
+ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+ {
+ gcc_assert (expr2->ts.type == BT_CHARACTER);
+ gcc_assert (strlen_lhs && strlen_rhs);
+ gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+ strlen_lhs, strlen_rhs, &block);
+ }
+
gfc_add_block_to_block (&block, &lse.post);
}
return gfc_finish_block (&block);
gfc_add_block_to_block (&block, &rse->pre);
gfc_add_block_to_block (&block, &lse->pre);
- gfc_add_modify_expr (&block, lse->expr,
+ gfc_add_modify (&block, lse->expr,
fold_convert (TREE_TYPE (lse->expr), rse->expr));
/* Do a deep copy if the rhs is a variable, if it is not the
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
- gfc_add_modify_expr (&block, lse->expr,
+ gfc_add_modify (&block, lse->expr,
fold_convert (TREE_TYPE (lse->expr), rse->expr));
}
/* Check for a dependency. */
if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
expr2->value.function.esym,
- expr2->value.function.actual))
+ expr2->value.function.actual,
+ NOT_ELEMENTAL))
return NULL;
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
/* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
that constructs the call to __builtin_memcpy. */
-static tree
+tree
gfc_build_memcpy_call (tree dst, tree src, tree len)
{
tree tmp;
stmtblock_t block;
stmtblock_t body;
bool l_is_temp;
+ bool scalar_to_array;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
else
gfc_conv_expr (&lse, expr1);
+ /* Assignments of scalar derived types with allocatable components
+ to arrays must be done with a deep copy and the rhs temporary
+ must have its components deallocated afterwards. */
+ scalar_to_array = (expr2->ts.type == BT_DERIVED
+ && expr2->ts.derived->attr.alloc_comp
+ && expr2->expr_type != EXPR_VARIABLE
+ && !gfc_is_constant_expr (expr2)
+ && expr1->rank && !expr2->rank);
+ if (scalar_to_array)
+ {
+ tmp = gfc_deallocate_alloc_comp (expr2->ts.derived, rse.expr, 0);
+ gfc_add_expr_to_block (&loop.post, tmp);
+ }
+
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
l_is_temp || init_flag,
- expr2->expr_type == EXPR_VARIABLE);
+ (expr2->expr_type == EXPR_VARIABLE)
+ || scalar_to_array);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)