#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. */
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;
}
{
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;
&& 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;
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;
}
{
/* 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");
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);
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 = build_fold_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)
+ /* 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
handling aliased arrays. */
static void
-gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
+gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
+ int g77, sym_intent intent)
{
gfc_se lse;
gfc_se rse;
loop.temp_ss->data.temp.type = base_type;
if (expr->ts.type == BT_CHARACTER)
- loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+ {
+ 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;
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);
+ if (intent != INTENT_OUT)
+ {
+ 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);
+ }
+ 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. */
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. */
+ optimized further. */
info = &rse.ss->data.info;
tmp_index = gfc_index_zero_node;
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,
+ and following it by the post-block of the first 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);
+ 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);
if (ref->type == REF_ARRAY)
seen_array = true;
- if (ref->next == NULL && ref->type == REF_COMPONENT)
+ if (ref->next == NULL
+ && ref->type != REF_ARRAY)
return seen_array;
}
return false;
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;
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
/* 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;
+ 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);
}
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);
+ 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
}
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;
- if (arg->expr->expr_type == EXPR_VARIABLE
- && is_aliased_array (arg->expr))
+
+ 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, arg->expr, f);
+ gfc_conv_aliased_arg (&parmse, e, f,
+ fsym ? fsym->attr.intent : INTENT_INOUT);
else
- gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
+ 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 an optional argument is itself an optional dummy argument,
+ check its presence and substitute a null if absent. */
+ if (e && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional
+ && fsym && fsym->attr.optional)
+ gfc_conv_missing_dummy (&parmse, e, fsym->ts);
+
+ if (fsym && 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);
+
+ /* If an INTENT(OUT) dummy of derived type has a default
+ initializer, it must be (re)initialized here. */
+ if (fsym && fsym->attr.intent == INTENT_OUT && fsym->ts.type == BT_DERIVED
+ && fsym->value)
+ {
+ gcc_assert (!fsym->attr.allocatable);
+ tmp = gfc_trans_assignment (e, fsym->value);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
+ if (fsym && 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;
+ }
/* Character strings are passed as two parameters, a length and a
pointer. */
{
/* 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
- {
+ (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)
/* 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. 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]);
- 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_conv_descriptor_data_get (info->descriptor);
tmp = fold_build2 (NE_EXPR, boolean_type_node,
tmp, info->data);
- gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
+ gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
}
se->expr = info->descriptor;
/* Bundle in the string length. */
}
}
+ /* 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));
/* Deal with single character specially. */
dsc = gfc_to_single_character (dlen, dest);
return;
}
- 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 = build_function_call_expr (gfor_fndecl_copy_string, tmp);
+ /* 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);
}
}
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
{
return NULL;
/* Functions returning pointers need temporaries. */
- if (expr2->symtree->n.sym->attr.pointer)
+ 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
OSDN Git Service
