/* Expression translation
- Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "toplev.h"
#include "real.h"
#include "tree-gimple.h"
+#include "langhooks.h"
#include "flags.h"
#include "gfortran.h"
#include "trans.h"
}
+/* Converts a missing, dummy argument into a null or zero. */
+
+void
+gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts)
+{
+ tree present;
+ tree tmp;
+
+ present = gfc_conv_expr_present (arg->symtree->n.sym);
+ tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
+ build_int_cst (TREE_TYPE (se->expr), 0));
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ se->expr = tmp;
+ if (ts.type == BT_CHARACTER)
+ {
+ tmp = build_int_cst (gfc_charlen_type_node, 0);
+ tmp = build3 (COND_EXPR, gfc_charlen_type_node, present,
+ se->string_length, tmp);
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ se->string_length = tmp;
+ }
+ return;
+}
+
+
/* Get the character length of an expression, looking through gfc_refs
if necessary. */
if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
tmp = se->expr;
else
- tmp = gfc_build_indirect_ref (se->expr);
+ tmp = build_fold_indirect_ref (se->expr);
tmp = gfc_build_array_ref (tmp, start.expr);
se->expr = gfc_build_addr_expr (type, tmp);
}
gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
gfc_add_block_to_block (&se->pre, &end.pre);
}
- tmp =
- build2 (MINUS_EXPR, gfc_charlen_type_node,
- fold_convert (gfc_charlen_type_node, integer_one_node),
- start.expr);
- tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
- se->string_length = fold (tmp);
+ tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
+ build_int_cst (gfc_charlen_type_node, 1),
+ start.expr);
+ tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
+ tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
+ build_int_cst (gfc_charlen_type_node, 0));
+ se->string_length = tmp;
}
}
if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
- se->expr = gfc_build_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref (se->expr);
}
{
gfc_ref *ref;
gfc_symbol *sym;
+ tree parent_decl;
+ int parent_flag;
+ bool return_value;
+ bool alternate_entry;
+ bool entry_master;
sym = expr->symtree->n.sym;
if (se->ss != NULL)
se->expr = gfc_get_symbol_decl (sym);
+ /* Deal with references to a parent results or entries by storing
+ the current_function_decl and moving to the parent_decl. */
+ return_value = sym->attr.function && sym->result == sym;
+ alternate_entry = sym->attr.function && sym->attr.entry
+ && sym->result == sym;
+ entry_master = sym->attr.result
+ && sym->ns->proc_name->attr.entry_master
+ && !gfc_return_by_reference (sym->ns->proc_name);
+ parent_decl = DECL_CONTEXT (current_function_decl);
+
+ if ((se->expr == parent_decl && return_value)
+ || (sym->ns && sym->ns->proc_name
+ && parent_decl
+ && sym->ns->proc_name->backend_decl == parent_decl
+ && (alternate_entry || entry_master)))
+ parent_flag = 1;
+ else
+ parent_flag = 0;
+
/* Special case for assigning the return value of a function.
Self recursive functions must have an explicit return value. */
- if (se->expr == current_function_decl && sym->attr.function
- && (sym->result == sym))
- se_expr = gfc_get_fake_result_decl (sym);
+ if (return_value && (se->expr == current_function_decl || parent_flag))
+ se_expr = gfc_get_fake_result_decl (sym, parent_flag);
/* Similarly for alternate entry points. */
- else if (sym->attr.function && sym->attr.entry
- && (sym->result == sym)
- && sym->ns->proc_name->backend_decl == current_function_decl)
+ else if (alternate_entry
+ && (sym->ns->proc_name->backend_decl == current_function_decl
+ || parent_flag))
{
gfc_entry_list *el = NULL;
for (el = sym->ns->entries; el; el = el->next)
if (sym == el->sym)
{
- se_expr = gfc_get_fake_result_decl (sym);
+ se_expr = gfc_get_fake_result_decl (sym, parent_flag);
break;
}
}
- else if (sym->attr.result
- && sym->ns->proc_name->backend_decl == current_function_decl
- && sym->ns->proc_name->attr.entry_master
- && !gfc_return_by_reference (sym->ns->proc_name))
- se_expr = gfc_get_fake_result_decl (sym);
+ else if (entry_master
+ && (sym->ns->proc_name->backend_decl == current_function_decl
+ || parent_flag))
+ se_expr = gfc_get_fake_result_decl (sym, parent_flag);
if (se_expr)
se->expr = se_expr;
if (!sym->attr.dummy)
{
gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
- se->expr = gfc_build_addr_expr (NULL, se->expr);
+ se->expr = build_fold_addr_expr (se->expr);
}
return;
}
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result))
- se->expr = gfc_build_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref (se->expr);
}
else
{
/* Dereference non-character scalar dummy arguments. */
if (sym->attr.dummy && !sym->attr.dimension)
- se->expr = gfc_build_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref (se->expr);
/* Dereference scalar hidden result. */
if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
&& (sym->attr.function || sym->attr.result)
&& !sym->attr.dimension && !sym->attr.pointer)
- se->expr = gfc_build_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref (se->expr);
/* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
|| sym->attr.function
|| sym->attr.result
|| !sym->attr.dimension))
- se->expr = gfc_build_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref (se->expr);
}
ref = expr->ref;
&& ref->next == NULL && (se->descriptor_only))
return;
- gfc_conv_array_ref (se, &ref->u.ar);
+ gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
/* Return a pointer to an element. */
break;
if (expr->ts.type == BT_CHARACTER)
gfc_conv_string_parameter (se);
else
- se->expr = gfc_build_addr_expr (NULL, se->expr);
+ se->expr = build_fold_addr_expr (se->expr);
}
}
All other unary operators have an equivalent GIMPLE unary operator. */
if (code == TRUTH_NOT_EXPR)
se->expr = build2 (EQ_EXPR, type, operand.expr,
- convert (type, integer_zero_node));
+ build_int_cst (type, 0));
else
se->expr = build1 (code, type, operand.expr);
if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
{
tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
- fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
+ build_int_cst (TREE_TYPE (lhs), -1));
cond = build2 (EQ_EXPR, boolean_type_node, lhs,
- convert (TREE_TYPE (lhs), integer_one_node));
+ build_int_cst (TREE_TYPE (lhs), 1));
/* If rhs is even,
result = (lhs == 1 || lhs == -1) ? 1 : 0. */
if ((n & 1) == 0)
{
tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
- se->expr = build3 (COND_EXPR, type, tmp,
- convert (type, integer_one_node),
- convert (type, integer_zero_node));
+ se->expr = build3 (COND_EXPR, type, tmp, build_int_cst (type, 1),
+ build_int_cst (type, 0));
return 1;
}
/* If rhs is odd,
result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
- tmp = build3 (COND_EXPR, type, tmp,
- convert (type, integer_minus_one_node),
- convert (type, integer_zero_node));
- se->expr = build3 (COND_EXPR, type, cond,
- convert (type, integer_one_node),
- tmp);
+ tmp = build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
+ build_int_cst (type, 0));
+ se->expr = build3 (COND_EXPR, type, cond, build_int_cst (type, 1), tmp);
return 1;
}
tmp = gfc_chainon_list (NULL_TREE, lse.expr);
tmp = gfc_chainon_list (tmp, rse.expr);
- se->expr = fold (gfc_build_function_call (fndecl, tmp));
+ se->expr = build_function_call_expr (fndecl, tmp);
}
{
/* Create a temporary variable to hold the result. */
tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
- convert (gfc_charlen_type_node, integer_one_node));
+ build_int_cst (gfc_charlen_type_node, 1));
tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
tmp = build_array_type (gfc_character1_type_node, tmp);
var = gfc_create_var (tmp, "str");
/* Allocate a temporary to hold the result. */
var = gfc_create_var (type, "pstr");
args = gfc_chainon_list (NULL_TREE, len);
- tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
+ tmp = build_function_call_expr (gfor_fndecl_internal_malloc, args);
tmp = convert (type, tmp);
gfc_add_modify_expr (&se->pre, var, tmp);
/* Free the temporary afterwards. */
tmp = convert (pvoid_type_node, var);
args = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
gfc_add_expr_to_block (&se->post, tmp);
}
args = gfc_chainon_list (args, lse.expr);
args = gfc_chainon_list (args, rse.string_length);
args = gfc_chainon_list (args, rse.expr);
- tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
+ tmp = build_function_call_expr (gfor_fndecl_concat_string, args);
gfc_add_expr_to_block (&se->pre, tmp);
/* Add the cleanup for the operands. */
se->string_length = len;
}
-
/* Translates an op expression. Common (binary) cases are handled by this
function, others are passed on. Recursion is used in either case.
We use the fact that (op1.ts == op2.ts) (except for the power
switch (expr->value.op.operator)
{
case INTRINSIC_UPLUS:
+ case INTRINSIC_PARENTHESES:
gfc_conv_expr (se, expr->value.op.op1);
return;
gfc_conv_expr (&rse, expr->value.op.op2);
gfc_add_block_to_block (&se->pre, &rse.pre);
- /* For string comparisons we generate a library call, and compare the return
- value with 0. */
if (checkstring)
{
gfc_conv_string_parameter (&lse);
gfc_conv_string_parameter (&rse);
- tmp = NULL_TREE;
- tmp = gfc_chainon_list (tmp, lse.string_length);
- tmp = gfc_chainon_list (tmp, lse.expr);
- tmp = gfc_chainon_list (tmp, rse.string_length);
- tmp = gfc_chainon_list (tmp, rse.expr);
-
- /* Build a call for the comparison. */
- lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
- gfc_add_block_to_block (&lse.post, &rse.post);
+ lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
+ rse.string_length, rse.expr);
rse.expr = integer_zero_node;
+ gfc_add_block_to_block (&lse.post, &rse.post);
}
type = gfc_typenode_for_spec (&expr->ts);
gfc_add_block_to_block (&se->post, &lse.post);
}
+/* If a string's length is one, we convert it to a single character. */
+
+static tree
+gfc_to_single_character (tree len, tree str)
+{
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
+
+ if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
+ && TREE_INT_CST_HIGH (len) == 0)
+ {
+ str = fold_convert (pchar_type_node, str);
+ return build_fold_indirect_ref (str);
+ }
+
+ return NULL_TREE;
+}
+
+/* Compare two strings. If they are all single characters, the result is the
+ subtraction of them. Otherwise, we build a library call. */
+
+tree
+gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
+{
+ tree sc1;
+ tree sc2;
+ tree type;
+ tree tmp;
+
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
+
+ type = gfc_get_int_type (gfc_default_integer_kind);
+
+ sc1 = gfc_to_single_character (len1, str1);
+ sc2 = gfc_to_single_character (len2, str2);
+
+ /* Deal with single character specially. */
+ if (sc1 != NULL_TREE && sc2 != NULL_TREE)
+ {
+ sc1 = fold_convert (type, sc1);
+ sc2 = fold_convert (type, sc2);
+ tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
+ }
+ else
+ {
+ tmp = NULL_TREE;
+ tmp = gfc_chainon_list (tmp, len1);
+ tmp = gfc_chainon_list (tmp, str1);
+ tmp = gfc_chainon_list (tmp, len2);
+ tmp = gfc_chainon_list (tmp, str2);
+
+ /* Build a call for the comparison. */
+ tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
+ }
+
+ return tmp;
+}
static void
gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
sym->backend_decl = gfc_get_extern_function_decl (sym);
tmp = sym->backend_decl;
+ if (sym->attr.cray_pointee)
+ tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
+ gfc_get_symbol_decl (sym->cp_pointer));
if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
{
gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
- tmp = gfc_build_addr_expr (NULL, tmp);
+ tmp = build_fold_addr_expr (tmp);
}
}
se->expr = tmp;
type = gfc_typenode_for_spec (&sym->ts);
type = gfc_get_nodesc_array_type (type, sym->as, packed);
- var = gfc_create_var (type, "parm");
+ var = gfc_create_var (type, "ifm");
gfc_add_modify_expr (block, var, fold_convert (type, data));
return var;
new_sym->attr.referenced = 1;
new_sym->attr.dimension = sym->attr.dimension;
new_sym->attr.pointer = sym->attr.pointer;
+ new_sym->attr.allocatable = sym->attr.allocatable;
new_sym->attr.flavor = sym->attr.flavor;
/* Create a fake symtree for it. */
tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
tmp = build_pointer_type (tmp);
if (sym->attr.pointer)
- tmp = build_pointer_type (tmp);
-
- value = fold_convert (tmp, se->expr);
- if (sym->attr.pointer)
- value = gfc_build_indirect_ref (value);
+ value = build_fold_indirect_ref (se->expr);
+ else
+ value = se->expr;
+ value = fold_convert (tmp, value);
}
- /* If the argument is a scalar or a pointer to an array, dereference it. */
- else if (!sym->attr.dimension || sym->attr.pointer)
- value = gfc_build_indirect_ref (se->expr);
+ /* If the argument is a scalar, a pointer to an array or an allocatable,
+ dereference it. */
+ else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
+ value = build_fold_indirect_ref (se->expr);
+
+ /* For character(*), use the actual argument's descriptor. */
+ else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
+ value = build_fold_indirect_ref (se->expr);
/* If the argument is an array descriptor, use it to determine
information about the actual argument's shape. */
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
{
/* Get the actual argument's descriptor. */
- desc = gfc_build_indirect_ref (se->expr);
+ desc = build_fold_indirect_ref (se->expr);
/* Create the replacement variable. */
tmp = gfc_conv_descriptor_data_get (desc);
gfc_free_expr (expr);
}
+/* Returns a reference to a temporary array into which a component of
+ an actual argument derived type array is copied and then returned
+ after the function call.
+ TODO Get rid of this kludge, when array descriptors are capable of
+ handling aliased arrays. */
+
+static void
+gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
+ int g77, sym_intent intent)
+{
+ gfc_se lse;
+ gfc_se rse;
+ gfc_ss *lss;
+ gfc_ss *rss;
+ gfc_loopinfo loop;
+ gfc_loopinfo loop2;
+ gfc_ss_info *info;
+ tree offset;
+ tree tmp_index;
+ tree tmp;
+ tree base_type;
+ stmtblock_t body;
+ int n;
+
+ gcc_assert (expr->expr_type == EXPR_VARIABLE);
+
+ gfc_init_se (&lse, NULL);
+ gfc_init_se (&rse, NULL);
+
+ /* Walk the argument expression. */
+ rss = gfc_walk_expr (expr);
+
+ gcc_assert (rss != gfc_ss_terminator);
+
+ /* Initialize the scalarizer. */
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, rss);
+
+ /* Calculate the bounds of the scalarization. */
+ gfc_conv_ss_startstride (&loop);
+
+ /* Build an ss for the temporary. */
+ base_type = gfc_typenode_for_spec (&expr->ts);
+ if (GFC_ARRAY_TYPE_P (base_type)
+ || GFC_DESCRIPTOR_TYPE_P (base_type))
+ base_type = gfc_get_element_type (base_type);
+
+ loop.temp_ss = gfc_get_ss ();;
+ loop.temp_ss->type = GFC_SS_TEMP;
+ loop.temp_ss->data.temp.type = base_type;
+
+ if (expr->ts.type == BT_CHARACTER)
+ {
+ gfc_ref *char_ref = expr->ref;
+
+ for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next)
+ if (char_ref->type == REF_SUBSTRING)
+ {
+ gfc_se tmp_se;
+
+ expr->ts.cl = gfc_get_charlen ();
+ expr->ts.cl->next = char_ref->u.ss.length->next;
+ char_ref->u.ss.length->next = expr->ts.cl;
+
+ gfc_init_se (&tmp_se, NULL);
+ gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
+ gfc_array_index_type);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp_se.expr, gfc_index_one_node);
+ tmp = gfc_evaluate_now (tmp, &parmse->pre);
+ gfc_init_se (&tmp_se, NULL);
+ gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
+ gfc_array_index_type);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ tmp, tmp_se.expr);
+ expr->ts.cl->backend_decl = tmp;
+
+ break;
+ }
+ loop.temp_ss->data.temp.type
+ = gfc_typenode_for_spec (&expr->ts);
+ loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+ }
+
+ loop.temp_ss->data.temp.dimen = loop.dimen;
+ loop.temp_ss->next = gfc_ss_terminator;
+
+ /* Associate the SS with the loop. */
+ gfc_add_ss_to_loop (&loop, loop.temp_ss);
+
+ /* Setup the scalarizing loops. */
+ gfc_conv_loop_setup (&loop);
+
+ /* Pass the temporary descriptor back to the caller. */
+ info = &loop.temp_ss->data.info;
+ parmse->expr = info->descriptor;
+
+ /* Setup the gfc_se structures. */
+ gfc_copy_loopinfo_to_se (&lse, &loop);
+ gfc_copy_loopinfo_to_se (&rse, &loop);
+
+ rse.ss = rss;
+ lse.ss = loop.temp_ss;
+ gfc_mark_ss_chain_used (rss, 1);
+ gfc_mark_ss_chain_used (loop.temp_ss, 1);
+
+ /* Start the scalarized loop body. */
+ gfc_start_scalarized_body (&loop, &body);
+
+ /* Translate the expression. */
+ gfc_conv_expr (&rse, expr);
+
+ gfc_conv_tmp_array_ref (&lse);
+ gfc_advance_se_ss_chain (&lse);
+
+ if (intent != INTENT_OUT)
+ {
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
+ gfc_add_expr_to_block (&body, tmp);
+ gcc_assert (rse.ss == gfc_ss_terminator);
+ gfc_trans_scalarizing_loops (&loop, &body);
+ }
+ else
+ {
+ /* Make sure that the temporary declaration survives. */
+ tmp = gfc_finish_block (&body);
+ gfc_add_expr_to_block (&loop.pre, tmp);
+ }
+
+ /* Add the post block after the second loop, so that any
+ freeing of allocated memory is done at the right time. */
+ gfc_add_block_to_block (&parmse->pre, &loop.pre);
+
+ /**********Copy the temporary back again.*********/
+
+ gfc_init_se (&lse, NULL);
+ gfc_init_se (&rse, NULL);
+
+ /* Walk the argument expression. */
+ lss = gfc_walk_expr (expr);
+ rse.ss = loop.temp_ss;
+ lse.ss = lss;
+
+ /* Initialize the scalarizer. */
+ gfc_init_loopinfo (&loop2);
+ gfc_add_ss_to_loop (&loop2, lss);
+
+ /* Calculate the bounds of the scalarization. */
+ gfc_conv_ss_startstride (&loop2);
+
+ /* Setup the scalarizing loops. */
+ gfc_conv_loop_setup (&loop2);
+
+ gfc_copy_loopinfo_to_se (&lse, &loop2);
+ gfc_copy_loopinfo_to_se (&rse, &loop2);
+
+ gfc_mark_ss_chain_used (lss, 1);
+ gfc_mark_ss_chain_used (loop.temp_ss, 1);
+
+ /* Declare the variable to hold the temporary offset and start the
+ scalarized loop body. */
+ offset = gfc_create_var (gfc_array_index_type, NULL);
+ gfc_start_scalarized_body (&loop2, &body);
+
+ /* Build the offsets for the temporary from the loop variables. The
+ temporary array has lbounds of zero and strides of one in all
+ dimensions, so this is very simple. The offset is only computed
+ outside the innermost loop, so the overall transfer could be
+ optimized further. */
+ info = &rse.ss->data.info;
+
+ tmp_index = gfc_index_zero_node;
+ for (n = info->dimen - 1; n > 0; n--)
+ {
+ tree tmp_str;
+ tmp = rse.loop->loopvar[n];
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ tmp, rse.loop->from[n]);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, tmp_index);
+
+ tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ rse.loop->to[n-1], rse.loop->from[n-1]);
+ tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp_str, gfc_index_one_node);
+
+ tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ tmp, tmp_str);
+ }
+
+ 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);
+
+ tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ rse.loop->loopvar[0], offset);
+
+ /* Now use the offset for the reference. */
+ tmp = build_fold_indirect_ref (info->data);
+ rse.expr = gfc_build_array_ref (tmp, tmp_index);
+
+ if (expr->ts.type == BT_CHARACTER)
+ rse.string_length = expr->ts.cl->backend_decl;
+
+ gfc_conv_expr (&lse, expr);
+
+ gcc_assert (lse.ss == gfc_ss_terminator);
+
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Generate the copying loops. */
+ gfc_trans_scalarizing_loops (&loop2, &body);
+
+ /* Wrap the whole thing up by adding the second loop to the post-block
+ and following it by the post-block of the first loop. In this way,
+ if the temporary needs freeing, it is done after use! */
+ if (intent != INTENT_IN)
+ {
+ gfc_add_block_to_block (&parmse->post, &loop2.pre);
+ gfc_add_block_to_block (&parmse->post, &loop2.post);
+ }
+
+ gfc_add_block_to_block (&parmse->post, &loop.post);
+
+ gfc_cleanup_loop (&loop);
+ gfc_cleanup_loop (&loop2);
+
+ /* Pass the string length to the argument expression. */
+ if (expr->ts.type == BT_CHARACTER)
+ parmse->string_length = expr->ts.cl->backend_decl;
+
+ /* We want either the address for the data or the address of the descriptor,
+ depending on the mode of passing array arguments. */
+ if (g77)
+ parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
+ else
+ parmse->expr = build_fold_addr_expr (parmse->expr);
+
+ return;
+}
+
+/* Is true if the last array reference is followed by a component reference. */
+
+static bool
+is_aliased_array (gfc_expr * e)
+{
+ gfc_ref * ref;
+ bool seen_array;
+
+ seen_array = false;
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY)
+ seen_array = true;
+
+ if (ref->next == NULL
+ && ref->type != REF_ARRAY)
+ return seen_array;
+ }
+ return false;
+}
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
int
gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
- gfc_actual_arglist * arg)
+ gfc_actual_arglist * arg, tree append_args)
{
gfc_interface_mapping mapping;
tree arglist;
gfc_ss *argss;
gfc_ss_info *info;
int byref;
+ int parm_kind;
tree type;
tree var;
tree len;
gfc_formal_arglist *formal;
int has_alternate_specifier = 0;
bool need_interface_mapping;
+ bool callee_alloc;
gfc_typespec ts;
gfc_charlen cl;
+ gfc_expr *e;
+ gfc_symbol *fsym;
+ stmtblock_t post;
+ enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
arglist = NULL_TREE;
retargs = NULL_TREE;
else
info = NULL;
+ gfc_init_block (&post);
gfc_init_interface_mapping (&mapping);
need_interface_mapping = ((sym->ts.type == BT_CHARACTER
- && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
- || sym->attr.dimension);
+ && sym->ts.cl->length
+ && sym->ts.cl->length->expr_type
+ != EXPR_CONSTANT)
+ || sym->attr.dimension);
formal = sym->formal;
/* Evaluate the arguments. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
{
- if (arg->expr == NULL)
+ e = arg->expr;
+ fsym = formal ? formal->sym : NULL;
+ parm_kind = MISSING;
+ if (e == NULL)
{
if (se->ignore_optional)
gfc_init_se (&parmse, NULL);
parmse.expr = null_pointer_node;
if (arg->missing_arg_type == BT_CHARACTER)
- parmse.string_length = convert (gfc_charlen_type_node,
- integer_zero_node);
+ parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
}
}
else if (se->ss && se->ss->useflags)
{
/* An elemental function inside a scalarized loop. */
gfc_init_se (&parmse, se);
- gfc_conv_expr_reference (&parmse, arg->expr);
+ gfc_conv_expr_reference (&parmse, e);
+ parm_kind = ELEMENTAL;
}
else
{
/* A scalar or transformational function. */
gfc_init_se (&parmse, NULL);
- argss = gfc_walk_expr (arg->expr);
+ argss = gfc_walk_expr (e);
if (argss == gfc_ss_terminator)
{
- gfc_conv_expr_reference (&parmse, arg->expr);
- if (formal && formal->sym->attr.pointer
- && arg->expr->expr_type != EXPR_NULL)
+ gfc_conv_expr_reference (&parmse, e);
+ parm_kind = SCALAR;
+ if (fsym && fsym->attr.pointer
+ && e->expr_type != EXPR_NULL)
{
/* Scalar pointer dummy args require an extra level of
indirection. The null pointer already contains
this level of indirection. */
- parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
+ parm_kind = SCALAR_POINTER;
+ parmse.expr = build_fold_addr_expr (parmse.expr);
}
}
else
{
- /* If the procedure requires an explicit interface, the
- actual argument is passed according to the
- corresponding formal argument. If the corresponding
- formal argument is a POINTER or assumed shape, we do
- not use g77's calling convention, and pass the
- address of the array descriptor instead. Otherwise we
- use g77's calling convention. */
+ /* If the procedure requires an explicit interface, the actual
+ argument is passed according to the corresponding formal
+ argument. If the corresponding formal argument is a POINTER,
+ ALLOCATABLE or assumed shape, we do not use g77's calling
+ convention, and pass the address of the array descriptor
+ instead. Otherwise we use g77's calling convention. */
int f;
- f = (formal != NULL)
- && !formal->sym->attr.pointer
- && formal->sym->as->type != AS_ASSUMED_SHAPE;
+ f = (fsym != NULL)
+ && !(fsym->attr.pointer || fsym->attr.allocatable)
+ && fsym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
- gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
+
+ if (e->expr_type == EXPR_VARIABLE
+ && is_aliased_array (e))
+ /* The actual argument is a component reference to an
+ array of derived types. In this case, the argument
+ is converted to a temporary, which is passed and then
+ written back after the procedure call. */
+ gfc_conv_aliased_arg (&parmse, e, f,
+ fsym ? fsym->attr.intent : INTENT_INOUT);
+ else
+ gfc_conv_array_parameter (&parmse, e, argss, f);
+
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ allocated on entry, it must be deallocated. */
+ if (fsym && fsym->attr.allocatable
+ && fsym->attr.intent == INTENT_OUT)
+ {
+ tmp = e->symtree->n.sym->backend_decl;
+ if (e->symtree->n.sym->attr.dummy)
+ tmp = build_fold_indirect_ref (tmp);
+ tmp = gfc_trans_dealloc_allocated (tmp);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
}
}
- if (formal && need_interface_mapping)
- gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
+ if (fsym)
+ {
+ if (e)
+ {
+ /* If an optional argument is itself an optional dummy
+ argument, check its presence and substitute a null
+ if absent. */
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional
+ && fsym->attr.optional)
+ gfc_conv_missing_dummy (&parmse, e, fsym->ts);
+
+ /* If an INTENT(OUT) dummy of derived type has a default
+ initializer, it must be (re)initialized here. */
+ if (fsym->attr.intent == INTENT_OUT
+ && fsym->ts.type == BT_DERIVED
+ && fsym->value)
+ {
+ gcc_assert (!fsym->attr.allocatable);
+ tmp = gfc_trans_assignment (e, fsym->value, false);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
+ /* Obtain the character length of an assumed character
+ length procedure from the typespec. */
+ if (fsym->ts.type == BT_CHARACTER
+ && 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)
+ {
+ gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
+ parmse.string_length
+ = e->symtree->n.sym->ts.cl->backend_decl;
+ }
+ }
+
+ if (need_interface_mapping)
+ gfc_add_interface_mapping (&mapping, fsym, &parmse);
+ }
gfc_add_block_to_block (&se->pre, &parmse.pre);
- gfc_add_block_to_block (&se->post, &parmse.post);
+ 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). */
+ 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)))
+ {
+ int parm_rank;
+ tmp = build_fold_indirect_ref (parmse.expr);
+ parm_rank = e->rank;
+ switch (parm_kind)
+ {
+ case (ELEMENTAL):
+ case (SCALAR):
+ parm_rank = 0;
+ break;
+
+ 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);
+ }
+ }
/* Character strings are passed as two parameters, a length and a
pointer. */
ts = sym->ts;
if (ts.type == BT_CHARACTER)
{
- /* Calculate the length of the returned string. */
- gfc_init_se (&parmse, NULL);
- if (need_interface_mapping)
- gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
- else
- gfc_conv_expr (&parmse, sym->ts.cl->length);
- gfc_add_block_to_block (&se->pre, &parmse.pre);
- gfc_add_block_to_block (&se->post, &parmse.post);
+ if (sym->ts.cl->length == NULL)
+ {
+ /* Assumed character length results are not allowed by 5.1.1.5 of the
+ standard and are trapped in resolve.c; except in the case of SPREAD
+ (and other intrinsics?) and dummy functions. In the case of SPREAD,
+ we take the character length of the first argument for the result.
+ For dummies, we have to look through the formal argument list for
+ this function and use the character length found there.*/
+ if (!sym->attr.dummy)
+ cl.backend_decl = TREE_VALUE (stringargs);
+ else
+ {
+ formal = sym->ns->proc_name->formal;
+ for (; formal; formal = formal->next)
+ if (strcmp (formal->sym->name, sym->name) == 0)
+ cl.backend_decl = formal->sym->ts.cl->backend_decl;
+ }
+ }
+ else
+ {
+ /* Calculate the length of the returned string. */
+ gfc_init_se (&parmse, NULL);
+ if (need_interface_mapping)
+ gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
+ else
+ gfc_conv_expr (&parmse, sym->ts.cl->length);
+ gfc_add_block_to_block (&se->pre, &parmse.pre);
+ gfc_add_block_to_block (&se->post, &parmse.post);
+ cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
+ }
/* Set up a charlen structure for it. */
cl.next = NULL;
cl.length = NULL;
- cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
ts.cl = &cl;
len = cl.backend_decl;
/* Evaluate the bounds of the result, if known. */
gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
- /* Allocate a temporary to store the result. */
- gfc_trans_allocate_temp_array (&se->pre, &se->post,
- se->loop, info, tmp, false);
-
- /* Zero the first stride to indicate a temporary. */
- tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
- gfc_add_modify_expr (&se->pre, tmp,
- convert (TREE_TYPE (tmp), integer_zero_node));
+ /* Create a temporary to store the result. In case the function
+ returns a pointer, the temporary will be a shallow copy and
+ 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,
+ true);
/* Pass the temporary as the first argument. */
tmp = info->descriptor;
- tmp = gfc_build_addr_expr (NULL, tmp);
+ tmp = build_fold_addr_expr (tmp);
retargs = gfc_chainon_list (retargs, tmp);
}
else if (ts.type == BT_CHARACTER)
var = gfc_create_var (build_pointer_type (tmp), "pstr");
/* Provide an address expression for the function arguments. */
- var = gfc_build_addr_expr (NULL, var);
+ var = build_fold_addr_expr (var);
}
else
var = gfc_conv_string_tmp (se, type, len);
gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
type = gfc_get_complex_type (ts.kind);
- var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
+ var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
retargs = gfc_chainon_list (retargs, var);
}
/* Add the hidden string length parameters to the arguments. */
arglist = chainon (arglist, stringargs);
+ /* We may want to append extra arguments here. This is used e.g. for
+ calls to libgfortran_matmul_??, which need extra information. */
+ if (append_args != NULL_TREE)
+ arglist = chainon (arglist, append_args);
+
/* Generate the actual call. */
gfc_conv_function_val (se, sym);
/* If there are alternate return labels, function type should be
TREE_TYPE (sym->backend_decl)
= build_function_type (integer_type_node,
TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
- se->expr = gfc_build_addr_expr (NULL, sym->backend_decl);
+ se->expr = build_fold_addr_expr (sym->backend_decl);
}
fntype = TREE_TYPE (TREE_TYPE (se->expr));
x = f()
where f is pointer valued, we have to dereference the result. */
if (!se->want_pointer && !byref && sym->attr.pointer)
- se->expr = gfc_build_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref (se->expr);
/* f2c calling conventions require a scalar default real function to
return a double precision result. Convert this back to default
/* Check the data pointer hasn't been modified. This would
happen in a function returning a pointer. */
tmp = gfc_conv_descriptor_data_get (info->descriptor);
- tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
- gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
+ tmp = fold_build2 (NE_EXPR, boolean_type_node,
+ tmp, info->data);
+ gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
}
se->expr = info->descriptor;
/* Bundle in the string length. */
{
/* Dereference for character pointer results. */
if (sym->attr.pointer || sym->attr.allocatable)
- se->expr = gfc_build_indirect_ref (var);
+ se->expr = build_fold_indirect_ref (var);
else
se->expr = var;
else
{
gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
- se->expr = gfc_build_indirect_ref (var);
+ se->expr = build_fold_indirect_ref (var);
}
}
}
+ /* Follow the function call with the argument post block. */
+ if (byref)
+ gfc_add_block_to_block (&se->pre, &post);
+ else
+ gfc_add_block_to_block (&se->post, &post);
+
return has_alternate_specifier;
}
/* Generate code to copy a string. */
static void
-gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
- tree slen, tree src)
+gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
+ tree slength, tree src)
{
- tree tmp;
+ tree tmp, dlen, slen;
+ tree dsc;
+ tree ssc;
+ tree cond;
+ tree cond2;
+ tree tmp2;
+ tree tmp3;
+ tree tmp4;
+ stmtblock_t tempblock;
+
+ dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
+ slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
- tmp = NULL_TREE;
- tmp = gfc_chainon_list (tmp, dlen);
- tmp = gfc_chainon_list (tmp, dest);
- tmp = gfc_chainon_list (tmp, slen);
- tmp = gfc_chainon_list (tmp, src);
- tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
+ /* Deal with single character specially. */
+ dsc = gfc_to_single_character (dlen, dest);
+ ssc = gfc_to_single_character (slen, src);
+ if (dsc != NULL_TREE && ssc != NULL_TREE)
+ {
+ gfc_add_modify_expr (block, dsc, ssc);
+ return;
+ }
+
+ /* Do nothing if the destination length is zero. */
+ cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
+ build_int_cst (gfc_charlen_type_node, 0));
+
+ /* The following code was previously in _gfortran_copy_string:
+
+ // The two strings may overlap so we use memmove.
+ void
+ copy_string (GFC_INTEGER_4 destlen, char * dest,
+ GFC_INTEGER_4 srclen, const char * src)
+ {
+ if (srclen >= destlen)
+ {
+ // This will truncate if too long.
+ memmove (dest, src, destlen);
+ }
+ else
+ {
+ memmove (dest, src, srclen);
+ // Pad with spaces.
+ memset (&dest[srclen], ' ', destlen - srclen);
+ }
+ }
+
+ We're now doing it here for better optimization, but the logic
+ is the same. */
+
+ /* Truncate string if source is too long. */
+ cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
+ tmp2 = gfc_chainon_list (NULL_TREE, dest);
+ tmp2 = gfc_chainon_list (tmp2, src);
+ tmp2 = gfc_chainon_list (tmp2, dlen);
+ tmp2 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp2);
+
+ /* Else copy and pad with spaces. */
+ tmp3 = gfc_chainon_list (NULL_TREE, dest);
+ tmp3 = gfc_chainon_list (tmp3, src);
+ tmp3 = gfc_chainon_list (tmp3, slen);
+ tmp3 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp3);
+
+ tmp4 = fold_build2 (PLUS_EXPR, pchar_type_node, dest,
+ fold_convert (pchar_type_node, slen));
+ tmp4 = gfc_chainon_list (NULL_TREE, tmp4);
+ tmp4 = gfc_chainon_list (tmp4, build_int_cst
+ (gfc_get_int_type (gfc_c_int_kind),
+ lang_hooks.to_target_charset (' ')));
+ tmp4 = gfc_chainon_list (tmp4, fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
+ dlen, slen));
+ tmp4 = build_function_call_expr (built_in_decls[BUILT_IN_MEMSET], tmp4);
+
+ gfc_init_block (&tempblock);
+ gfc_add_expr_to_block (&tempblock, tmp3);
+ gfc_add_expr_to_block (&tempblock, tmp4);
+ tmp3 = gfc_finish_block (&tempblock);
+
+ /* The whole copy_string function is there. */
+ tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
+ tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (block, tmp);
}
sym = expr->value.function.esym;
if (!sym)
sym = expr->symtree->n.sym;
- gfc_conv_function_call (se, sym, expr->value.function.actual);
+ gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
}
gfc_conv_expr (&rse, expr);
- tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
gfc_add_expr_to_block (&body, tmp);
gcc_assert (rse.ss == gfc_ss_terminator);
return gfc_finish_block (&block);
}
+
/* Assign a single component of a derived type constructor. */
static tree
gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
gfc_se se;
+ gfc_se lse;
gfc_ss *rss;
stmtblock_t block;
tree tmp;
+ tree offset;
+ int n;
gfc_start_block (&block);
+
if (cm->pointer)
{
gfc_init_se (&se, NULL);
}
else if (cm->dimension)
{
- tmp = gfc_trans_subarray_assign (dest, cm, expr);
- gfc_add_expr_to_block (&block, tmp);
+ if (cm->allocatable && expr->expr_type == EXPR_NULL)
+ gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+ else if (cm->allocatable)
+ {
+ tree tmp2;
+
+ gfc_init_se (&se, NULL);
+
+ rss = gfc_walk_expr (expr);
+ se.want_pointer = 0;
+ gfc_conv_expr_descriptor (&se, expr, rss);
+ gfc_add_block_to_block (&block, &se.pre);
+
+ tmp = fold_convert (TREE_TYPE (dest), se.expr);
+ gfc_add_modify_expr (&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);
+ else
+ tmp = gfc_duplicate_allocatable (dest, se.expr,
+ TREE_TYPE(cm->backend_decl),
+ 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);
+
+ /* 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);
+ tmp2 =gfc_create_var (gfc_array_index_type, NULL);
+ for (n = 0; n < expr->rank; n++)
+ {
+ if (expr->expr_type != EXPR_VARIABLE
+ && expr->expr_type != EXPR_CONSTANT)
+ {
+ tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
+ gfc_add_modify_expr (&block, tmp,
+ fold_build2 (PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node));
+ tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
+ gfc_add_modify_expr (&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);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
+ gfc_add_modify_expr (&block, offset, tmp);
+ }
+ }
+ else
+ {
+ tmp = gfc_trans_subarray_assign (dest, cm, expr);
+ gfc_add_expr_to_block (&block, tmp);
+ }
}
else if (expr->ts.type == BT_DERIVED)
{
- /* Nested derived type. */
- tmp = gfc_trans_structure_assign (dest, expr);
- gfc_add_expr_to_block (&block, tmp);
+ if (expr->expr_type != EXPR_STRUCTURE)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, expr);
+ gfc_add_modify_expr (&block, dest,
+ fold_convert (TREE_TYPE (dest), se.expr));
+ }
+ else
+ {
+ /* Nested constructors. */
+ tmp = gfc_trans_structure_assign (dest, expr);
+ gfc_add_expr_to_block (&block, tmp);
+ }
}
else
{
/* Scalar component. */
- gfc_se lse;
-
gfc_init_se (&se, NULL);
gfc_init_se (&lse, NULL);
if (cm->ts.type == BT_CHARACTER)
lse.string_length = cm->ts.cl->backend_decl;
lse.expr = dest;
- tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
}
cm = expr->ts.derived->components;
+
for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
{
- /* Skip absent members in default initializers. */
- if (!c->expr)
+ /* Skip absent members in default initializers and allocatable
+ 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)
continue;
val = gfc_conv_initializer (c->expr, &cm->ts,
}
/* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
- numeric expressions. Used for scalar values whee inserting cleanup code
+ numeric expressions. Used for scalar values where inserting cleanup code
is inconvenient. */
void
gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
gfc_add_block_to_block (&se->pre, &se->post);
/* Take the address of that value. */
- se->expr = gfc_build_addr_expr (NULL, var);
+ se->expr = build_fold_addr_expr (var);
}
{
case EXPR_NULL:
/* Just set the data pointer to null. */
- gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
+ gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
break;
case EXPR_VARIABLE:
/* Generate code for assignment of scalar variables. Includes character
- strings. */
+ strings and derived types with allocatable components. */
tree
-gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
+gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
+ bool l_is_temp, bool r_is_var)
{
stmtblock_t block;
+ tree tmp;
+ tree cond;
gfc_init_block (&block);
- if (type == BT_CHARACTER)
+ if (ts.type == BT_CHARACTER)
{
gcc_assert (lse->string_length != NULL_TREE
&& rse->string_length != NULL_TREE);
gfc_trans_string_copy (&block, lse->string_length, lse->expr,
rse->string_length, rse->expr);
}
+ else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
+ {
+ cond = NULL_TREE;
+
+ /* Are the rhs and the lhs the same? */
+ if (r_is_var)
+ {
+ cond = fold_build2 (EQ_EXPR, boolean_type_node,
+ build_fold_addr_expr (lse->expr),
+ build_fold_addr_expr (rse->expr));
+ cond = gfc_evaluate_now (cond, &lse->pre);
+ }
+
+ /* Deallocate the lhs allocated components as long as it is not
+ the same as the rhs. */
+ if (!l_is_temp)
+ {
+ tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
+ if (r_is_var)
+ tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
+ gfc_add_expr_to_block (&lse->pre, tmp);
+ }
+
+ gfc_add_block_to_block (&block, &lse->pre);
+ gfc_add_block_to_block (&block, &rse->pre);
+
+ gfc_add_modify_expr (&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
+ same as the lhs. */
+ if (r_is_var)
+ {
+ tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
+ tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ }
else
{
gfc_add_block_to_block (&block, &lse->pre);
if (gfc_ref_needs_temporary_p (expr1->ref))
return NULL;
+ /* Functions returning pointers need temporaries. */
+ if (expr2->symtree->n.sym->attr.pointer
+ || expr2->symtree->n.sym->attr.allocatable)
+ return NULL;
+
/* Check that no LHS component references appear during an array
reference. This is needed because we do not have the means to
span any arbitrary stride with an array descriptor. This check
setting up the scalarizer. */
tree
-gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
+gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
{
gfc_se lse;
gfc_se rse;
tree tmp;
stmtblock_t block;
stmtblock_t body;
+ bool l_is_temp;
/* Special case a single function returning an array. */
if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
else
gfc_init_block (&body);
+ l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
+
/* Translate the expression. */
gfc_conv_expr (&rse, expr2);
- if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
+ if (l_is_temp)
{
gfc_conv_tmp_array_ref (&lse);
gfc_advance_se_ss_chain (&lse);
else
gfc_conv_expr (&lse, expr1);
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+ l_is_temp || init_flag,
+ expr2->expr_type == EXPR_VARIABLE);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
gcc_assert (lse.ss == gfc_ss_terminator
&& rse.ss == gfc_ss_terminator);
- if (loop.temp_ss != NULL)
+ if (l_is_temp)
{
gfc_trans_scalarized_loop_boundary (&loop, &body);
gcc_assert (lse.ss == gfc_ss_terminator
&& rse.ss == gfc_ss_terminator);
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+ false, false);
gfc_add_expr_to_block (&body, tmp);
}
+
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop, &body);
}
tree
+gfc_trans_init_assign (gfc_code * code)
+{
+ return gfc_trans_assignment (code->expr, code->expr2, true);
+}
+
+tree
gfc_trans_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr, code->expr2);
+ return gfc_trans_assignment (code->expr, code->expr2, false);
}
OSDN Git Service
