{
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. */
+ parent_flag = 0;
+
+ 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
+ && 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 (sym->attr.function && sym->result == sym
+ && (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;
switch (expr->value.op.operator)
{
case INTRINSIC_UPLUS:
+ case INTRINSIC_PARENTHESES:
gfc_conv_expr (se, expr->value.op.op1);
return;
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. */
value = build_fold_indirect_ref (value);
}
- /* If the argument is a scalar or a pointer to an array, dereference it. */
- else if (!sym->attr.dimension || sym->attr.pointer)
+ /* 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
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)
+{
+ 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)
+ 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);
+
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+ gfc_add_expr_to_block (&body, tmp);
+
+ gcc_assert (rse.ss == gfc_ss_terminator);
+
+ gfc_trans_scalarizing_loops (&loop, &body);
+
+ /* 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
+ optimised 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.type);
+ 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 fist loop. In this way,
+ if the temporary needs freeing, it is done after use! */
+ 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_COMPONENT)
+ 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.
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)
}
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->attr.pointer || formal->sym->attr.allocatable)
&& formal->sym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
- gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
+ if (arg->expr->expr_type == EXPR_VARIABLE
+ && is_aliased_array (arg->expr))
+ /* 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, arg->expr, f);
+ else
+ gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
+
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ allocated on entry, it must be deallocated. */
+ if (formal && formal->sym->attr.allocatable
+ && formal->sym->attr.intent == INTENT_OUT)
+ {
+ tmp = gfc_trans_dealloc_allocated (arg->expr->symtree->n.sym);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
}
}
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);
+ 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?). In this case, we take the character length
+ of the first argument for the result. */
+ cl.backend_decl = TREE_VALUE (stringargs);
+ }
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);
+ {
+ /* 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);
+ /* Allocate 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. */
+ gfc_trans_allocate_temp_array (&se->pre, &se->post, se->loop, info,
+ tmp, false, !sym->attr.pointer);
/* Zero the first stride to indicate a temporary. */
tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
/* 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);
+ tmp = fold_build2 (NE_EXPR, boolean_type_node,
+ tmp, info->data);
gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
}
se->expr = info->descriptor;
}
/* 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)
if (gfc_ref_needs_temporary_p (expr1->ref))
return NULL;
+ /* Functions returning pointers need temporaries. */
+ if (expr2->symtree->n.sym->attr.pointer)
+ 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
OSDN Git Service
