/* Expression translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+ 2011
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
tree
gfc_string_to_single_character (tree len, tree str, int kind)
{
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
- if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0)
+ if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
+ || !POINTER_TYPE_P (TREE_TYPE (str)))
return NULL_TREE;
if (TREE_INT_CST_LOW (len) == 1)
argument and another one. */
if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
{
+ gfc_expr *iarg;
sym_intent intent;
if (fsym != NULL)
if (gfc_check_fncall_dependency (e, intent, sym, args,
NOT_ELEMENTAL))
parmse.force_tmp = 1;
+
+ iarg = e->value.function.actual->expr;
+
+ /* Temporary needed if aliasing due to host association. */
+ if (sym->attr.contained
+ && !sym->attr.pure
+ && !sym->attr.implicit_pure
+ && !sym->attr.use_assoc
+ && iarg->expr_type == EXPR_VARIABLE
+ && sym->ns == iarg->symtree->n.sym->ns)
+ parmse.force_tmp = 1;
+
+ /* Ditto within module. */
+ if (sym->attr.use_assoc
+ && !sym->attr.pure
+ && !sym->attr.implicit_pure
+ && iarg->expr_type == EXPR_VARIABLE
+ && sym->module == iarg->symtree->n.sym->module)
+ parmse.force_tmp = 1;
}
if (e->expr_type == EXPR_VARIABLE
/* If the lhs of an assignment x = f(..) is allocatable and
f2003 is allowed, we must do the automatic reallocation.
- TODO - deal with instrinsics, without using a temporary. */
+ TODO - deal with intrinsics, without using a temporary. */
if (gfc_option.flag_realloc_lhs
&& se->ss && se->ss->loop_chain
&& se->ss->loop_chain->is_alloc_lhs
if (!se->direct_byref)
{
- if (sym->attr.dimension || (comp && comp->attr.dimension))
+ if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
{
if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
fold_convert (size_type_node,
TYPE_SIZE_UNIT (chartype)));
- if (dlength)
+ if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
dest = fold_convert (pvoid_type_node, dest);
else
dest = gfc_build_addr_expr (pvoid_type_node, dest);
- if (slength)
+ if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
src = fold_convert (pvoid_type_node, src);
else
src = gfc_build_addr_expr (pvoid_type_node, src);
gcc_assert (fargs->sym->attr.dimension == 0);
fsym = fargs->sym;
- /* Create a temporary to hold the value. */
- type = gfc_typenode_for_spec (&fsym->ts);
- temp_vars[n] = gfc_create_var (type, fsym->name);
-
if (fsym->ts.type == BT_CHARACTER)
{
/* Copy string arguments. */
- tree arglen;
+ tree arglen;
- gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
+ gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
&& fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
- arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
- tmp = gfc_build_addr_expr (build_pointer_type (type),
- temp_vars[n]);
+ /* Create a temporary to hold the value. */
+ if (fsym->ts.u.cl->backend_decl == NULL_TREE)
+ fsym->ts.u.cl->backend_decl
+ = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
- gfc_conv_expr (&rse, args->expr);
- gfc_conv_string_parameter (&rse);
- gfc_add_block_to_block (&se->pre, &lse.pre);
- gfc_add_block_to_block (&se->pre, &rse.pre);
+ type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
+ temp_vars[n] = gfc_create_var (type, fsym->name);
+
+ arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
- gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
+ gfc_conv_expr (&rse, args->expr);
+ gfc_conv_string_parameter (&rse);
+ gfc_add_block_to_block (&se->pre, &lse.pre);
+ gfc_add_block_to_block (&se->pre, &rse.pre);
+
+ gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
rse.string_length, rse.expr, fsym->ts.kind);
- gfc_add_block_to_block (&se->pre, &lse.post);
- gfc_add_block_to_block (&se->pre, &rse.post);
+ gfc_add_block_to_block (&se->pre, &lse.post);
+ gfc_add_block_to_block (&se->pre, &rse.post);
}
else
{
/* For everything else, just evaluate the expression. */
+
+ /* Create a temporary to hold the value. */
+ type = gfc_typenode_for_spec (&fsym->ts);
+ temp_vars[n] = gfc_create_var (type, fsym->name);
+
gfc_conv_expr (&lse, args->expr);
gfc_add_block_to_block (&se->pre, &lse.pre);
gfc_class_null_initializer (&cm->ts));
gfc_add_expr_to_block (&block, tmp);
}
- else if (cm->attr.dimension)
+ else if (cm->attr.dimension && !cm->attr.proc_pointer)
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
gfc_start_block (&block);
cm = expr->ts.u.derived->components;
+
+ if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
+ && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
+ || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
+ {
+ gfc_se se, lse;
+
+ gcc_assert (cm->backend_decl == NULL);
+ gfc_init_se (&se, NULL);
+ gfc_init_se (&lse, NULL);
+ gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
+ lse.expr = dest;
+ gfc_add_modify (&block, lse.expr,
+ fold_convert (TREE_TYPE (lse.expr), se.expr));
+
+ return gfc_finish_block (&block);
+ }
+
for (c = gfc_constructor_first (expr->value.constructor);
c; c = gfc_constructor_next (c), cm = cm->next)
{
if (!c->expr)
continue;
- /* Handle c_null_(fun)ptr. */
- if (c && c->expr && c->expr->ts.is_iso_c)
- {
- field = cm->backend_decl;
- tmp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field),
- dest, field, NULL_TREE);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
- tmp, fold_convert (TREE_TYPE (tmp),
- null_pointer_node));
- gfc_add_expr_to_block (&block, tmp);
- continue;
- }
-
field = cm->backend_decl;
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
dest, field, NULL_TREE);
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
&& expr->ts.u.derived->attr.is_iso_c)
{
- if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
- || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
+ if (expr->expr_type == EXPR_VARIABLE
+ && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+ || expr->symtree->n.sym->intmod_sym_id
+ == ISOCBINDING_NULL_FUNPTR))
{
/* Set expr_type to EXPR_NULL, which will result in
null_pointer_node being used below. */
if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
return true;
+ /* If the lhs has been host_associated, is in common, a pointer or is
+ a target and the function is not using a RESULT variable, aliasing
+ can occur and a temporary is needed. */
+ if ((sym->attr.host_assoc
+ || sym->attr.in_common
+ || sym->attr.pointer
+ || sym->attr.cray_pointee
+ || sym->attr.target)
+ && expr2->symtree != NULL
+ && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
+ return true;
+
/* A PURE function can unconditionally be called without a temporary. */
if (expr2->value.function.esym != NULL
&& expr2->value.function.esym->attr.pure)
return false;
- /* TODO a function that could correctly be declared PURE but is not
- could do with returning false as well. */
+ /* Implicit_pure functions are those which could legally be declared
+ to be PURE. */
+ if (expr2->value.function.esym != NULL
+ && expr2->value.function.esym->attr.implicit_pure)
+ return false;
if (!sym->attr.use_assoc
&& !sym->attr.in_common
&& !sym->attr.pointer
&& !sym->attr.target
+ && !sym->attr.cray_pointee
&& expr2->value.function.esym)
{
/* A temporary is not needed if the function is not contained and
bool dealloc)
{
tree tmp;
-
+
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
{
gfc_error ("Assignment to deferred-length character variable at %L "
if (expr2->ts.type != BT_CLASS)
{
/* Insert an additional assignment which sets the '_vptr' field. */
+ gfc_symbol *vtab = NULL;
+ gfc_symtree *st;
+
lhs = gfc_copy_expr (expr1);
gfc_add_vptr_component (lhs);
+
if (expr2->ts.type == BT_DERIVED)
- {
- gfc_symbol *vtab;
- gfc_symtree *st;
- vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
- gcc_assert (vtab);
- rhs = gfc_get_expr ();
- rhs->expr_type = EXPR_VARIABLE;
- gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
- rhs->symtree = st;
- rhs->ts = vtab->ts;
- }
+ vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
else if (expr2->expr_type == EXPR_NULL)
- rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
- else
- gcc_unreachable ();
+ vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
+ gcc_assert (vtab);
+
+ rhs = gfc_get_expr ();
+ rhs->expr_type = EXPR_VARIABLE;
+ gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
+ rhs->symtree = st;
+ rhs->ts = vtab->ts;
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
OSDN Git Service
